Albert Dvornik <bert@alum.mit.edu>
Alberto Simões <ambs@cpan.org>
Alessandro Forghieri <alf@orion.it>
-Alexandre (Midnite) Jousset <mid@gtmp.org>
Alexander Alekseev <alex@alemate.ru>
Alexander Hartmaier <abraxxa@cpan.org>
Alexander Voronov <alexander-voronov@yandex.ru>
Andreas König <a.koenig@mind.de>
Andreas Marienborg <andreas.marienborg@gmail.com>
Andreas Schwab <schwab@suse.de>
-Andreas Voegele <andreas@andreasvoegele.com>
Andrei Yelistratov <andrew@sundale.net>
Andrej Borsenkow <Andrej.Borsenkow@mow.siemens.ru>
Andrew Bettison <andrewb@zip.com.au>
Andrew Burt <aburt@isis.cs.du.edu>
Andrew Cohen <cohen@andy.bu.edu>
andrew deryabin <djsf@technarchy.ru>
-Andrew Fresh <afresh1@openbsd.org>
Andrew Hamm <AHamm@civica.com.au>
Andrew M. Langmead <aml@world.std.com>
Andrew Pimlott <pimlott@idiomtech.com>
Andy Lester <andy@petdance.com>
Anno Siegel <anno4000@lublin.zrz.tu-berlin.de>
Anthony David <adavid@netinfo.com.au>
-Anthony Heading <anthony@ajrh.net>
Anton Berezin <tobez@tobez.org>
Anton Nikishaev <me@lelf.lu>
Anton Tagunov <tagunov@motor.ru>
Dominic Hargreaves <dom@earth.li>
Dominique Dumont <Dominique_Dumont@grenoble.hp.com>
Dominique Quatravaux
-Doug Bell <madcityzen@gmail.com>
Doug Campbell <soup@ampersand.com>
Doug MacEachern <dougm@covalent.net>
Douglas Christopher Wilson <doug@somethingdoug.com>
Duncan Findlay <duncf@debian.org>
E. Choroba <choroba@weed.(none)>
Ed Avis <eda@waniasset.com>
-Ed J <etj@cpan.org>
Ed Mooring <mooring@Lynx.COM>
Ed Santiago <esm@pobox.com>
Eddy Tan <eddy.net@gmail.com>
Gideon Israel Dsouza <gideon@cpan.org>
Giles Lean <giles@nemeton.com.au>
Gisle Aas <gisle@aas.no>
-Glenn D. Golden <gdg@zplane.com>
Glenn Linderman <perl@nevcal.com>
Gordon Lack <gml4410@ggr.co.uk>
Gordon J. Miller <gjm@cray.com>
James Jurach <muaddib@erf.net>
James E Keenan <jkeenan@cpan.org>
James Mastros <james@mastros.biz>
-James McCoy <vega.james@gmail.com>
Jamshid Afshar
Jan D. <jan.djarv@mbox200.swipnet.se>
Jan Dubois <jand@activestate.com>
Johan Holtman
Johan Vromans <jvromans@squirrel.nl>
Johann Klasek <jk@auto.tuwien.ac.at>
-Johann 'Myrkraverk' Oskarsson <johann@myrkraverk.com>
Johannes Plunien <plu@pqpq.de>
John Bley <jbb6@acpub.duke.edu>
John Borwick <jhborwic@unity.ncsu.edu>
Kriton Kyrimis <kyrimis@princeton.edu>
Kurt D. Starsinic <kstar@wolfetech.com>
Kyriakos Georgiou
-Lajos Veres <vlajos@gmail.com>
Larry Parmelee <parmelee@CS.Cornell.EDU>
Larry Schuler
Larry Schwimmer <rosebud@cyclone.Stanford.EDU>
Merijn Broeren <merijnb@iloquent.nl>
Michael A Chase <mchase@ix.netcom.com>
Michael Breen <perl@mbreen.com>
-Michael Bunk <bunk@iat.uni-leipzig.de>
Michael Carman <mjcarman@home.com>
Michael Cook <mcook@cognex.com>
Michael Cummings <mcummings@gentoo.org>
Randall Gellens <randy@qualcomm.com>
Randolf Werner <randolf.werner@sap.com>
Randy J. Ray <rjray@redhat.com>
-Randy Stauner <rwstauner@cpan.org>
Randy W. Sims
Raphael Manfredi <Raphael.Manfredi@pobox.com>
Raul Dias <raul@dias.com.br>
Sven Strickroth <sven.strickroth@tu-clausthal.de>
Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
SynaptiCAD, Inc. <sales@syncad.com>
-Tadeusz Sośnierz <tadeusz.sosnierz@onet.pl>
Takis Psarogiannakopoulos <takis@xfree86.org>
Taro KAWAGISHI
Tassilo von Parseval <tassilo.parseval@post.rwth-aachen.de>
Tobias Leich <email@froggs.de>
Toby Inkster <mail@tobyinkster.co.uk>
Todd C. Miller <Todd.Miller@courtesan.com>
-Todd Rinaldo <toddr@cpan.org>
+Todd Rinaldo <toddr@cpanel.net>
Todd T. Fries <todd@fries.int.mrleng.com>
Todd Vierling <tv@duh.org>
Tokuhiro Matsuno <tokuhirom@gmail.com>
Vishal Bhatia <vishal@deja.com>
Vlad Harchev <hvv@hippo.ru>
Vladimir Alexiev <vladimir@cs.ualberta.ca>
-Vladimir Marek <vlmarek@volny.cz>
Vladimir Timofeev <vovkasm@gmail.com>
Volker Schatz <perldoc@volkerschatz.com>
W. Geoffrey Rommel <grommel@sears.com>
# See Porting/pumpkin.pod for more information on metaconfig.
#
-# Generated on Wed Jun 4 08:58:13 CEST 2014 [metaconfig 3.5 PL0]
+# Generated on Wed Apr 9 12:24:24 CEST 2014 [metaconfig 3.5 PL0]
# (with additional metaconfig patches by perlbug@perl.org)
cat >c1$$ <<EOF
: Proper separator for the PATH environment variable
p_=:
: On OS/2 this directory should exist if this is not floppy only system ":-]"
-if test -d c:/. || ( uname -a | grep -i 'os\(/\|\)2' 2>&1 ) 2>&1 >/dev/null ; then
+if test -d c:/. || ( uname -a | grep -i 'os\(/\|\)2' ) 2>&1 >/dev/null ; then
if test -n "$OS2_SHELL"; then
p_=\;
PATH=`cmd /c "echo %PATH%" | tr '\\\\' / `
: set usesocks on the Configure command line to enable socks.
: List of libraries we want.
: If anyone needs extra -lxxx, put those in a hint file.
-libswanted="cl pthread socket bind inet nsl nm ndbm gdbm dbm db malloc dl ld"
-libswanted="$libswanted sun m crypt sec util c cposix posix ucb bsd BSD"
+libswanted="socket bind inet nsl nm ndbm gdbm dbm db malloc dl ld sun"
+libswanted="$libswanted m crypt sec util c cposix posix ucb bsd BSD"
: We probably want to search /usr/shlib before most other libraries.
: This is only used by the lib/ExtUtils/MakeMaker.pm routine extliblist.
glibpth=`echo " $glibpth " | sed -e 's! /usr/shlib ! !'`
esac
case "$less" in
'') ;;
-*) if $less -R </dev/null >/dev/null 2>&1; then
+*) if $less -R </dev/null >/dev/null; then
echo "Substituting less -R for less."
less="$less -R"
_less=$less
$sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4
$test -d /usr/apollo/bin && osname=apollo
$test -f /etc/saf/_sactab && osname=svr4
- $test -d /usr/include/minix && osname=minix && osvers=`$uname -r`
+ $test -d /usr/include/minix && osname=minix
$test -f /system/gnu_library/bin/ar.pm && osname=vos
if $test -d /MachTen -o -d /MachTen_Folder; then
osname=machten
freebsd|mirbsd|netbsd|openbsd|interix|dragonfly|bitrig)
xxx="-Wl,-R$shrpdir"
;;
- bsdos|linux|irix*|dec_osf|gnu*|haiku)
+ bsdos|linux|irix*|dec_osf|gnu*)
xxx="-Wl,-rpath,$shrpdir"
;;
next)
# next doesn't like the default...
;;
+ haiku)
+ # Haiku doesn't like the default, either.
+ ;;
hpux*)
# hpux doesn't like the default, either.
tmp_shrpenv="env LDOPTS=\"+s +b${shrpdir}\""
h_shm=false
val="$undef"
set shmctl d_shmctl
- eval $setvar
+ evat $setvar
set shmget d_shmget
- eval $setvar
+ evat $setvar
set shmat d_shmat
- eval $setvar
+ evat $setvar
set shmdt d_shmdt
- eval $setvar
+ evat $setvar
;;
esac
;;
int main (int argc, char *argv[])
{
- /* fprintf (stderr, "Sizeof time_t = %ld\n", sizeof (time_t)); */
+ fprintf (stderr, "Sizeof time_t = %ld\n", sizeof (time_t));
check_max ();
check_min ();
return (0);
z8000
EOSH
# Maybe put other stuff here too.
-./tr '-' '_' <<EOSH >>Cppsym.know
+cat <<EOSH >>Cppsym.know
$osname
EOSH
./tr '[a-z]' '[A-Z]' < Cppsym.know > Cppsym.a
Scalar/List/Utils) this_ext="List/Util" ;;
PathTools) this_ext="Cwd" ;;
esac;
- echo " $xs_extensions $nonxs_extensions" > $tdir/$$.tmp;
- if $contains " $this_ext " $tdir/$$.tmp; then
+ echo " $xs_extensions $nonxs_extensions" > $$.tmp;
+ if $contains " $this_ext " $$.tmp; then
echo >&4;
echo "Duplicate directories detected for extension $xxx" >&4;
echo "Configure cannot correctly recover from this - shall I abort?" >&4;
esac;
echo "Ok. You will need to correct config.sh before running make." >&4;
fi;
- $ls -1 $xxx > $tdir/$$.tmp;
- if $contains "\.xs$" $tdir/$$.tmp > /dev/null 2>&1; then
+ $ls -1 $xxx > $$.tmp;
+ if $contains "\.xs$" $$.tmp > /dev/null 2>&1; then
xs_extensions="$xs_extensions $this_ext";
- elif $contains "\.c$" $tdir/$$.tmp > /dev/null 2>&1; then
+ elif $contains "\.c$" $$.tmp > /dev/null 2>&1; then
xs_extensions="$xs_extensions $this_ext";
elif $test -d $xxx; then
nonxs_extensions="$nonxs_extensions $this_ext";
fi;
- $rm -f $tdir/$$.tmp;
+ $rm -f $$.tmp;
;;
esac;
done'
aphostname='/bin/hostname'
api_revision='5'
api_subversion='0'
-api_version='20'
-api_versionstring='5.20.0'
+api_version='21'
+api_versionstring='5.21.0'
ar='ar'
-archlib='/usr/lib/perl5/5.20.3/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.20.3/armv4l-linux'
+archlib='/usr/lib/perl5/5.21.0/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.21.0/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='cc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.20.3/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.0/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.20.3/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.21.0/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.20.3'
+installprivlib='./install_me_here/usr/lib/perl5/5.21.0'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.20.3/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.0/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.20.3'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.0'
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.20.3'
-privlibexp='/usr/lib/perl5/5.20.3'
+privlib='/usr/lib/perl5/5.21.0'
+privlibexp='/usr/lib/perl5/5.21.0'
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.20.3/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.20.3/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.21.0/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.21.0/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.20.3'
+sitelib='/usr/lib/perl5/site_perl/5.21.0'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.20.3'
+sitelibexp='/usr/lib/perl5/site_perl/5.21.0'
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='3'
+subversion='0'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.20.3'
-version_patchlevel_string='version 20 subversion 3'
+version='5.21.0'
+version_patchlevel_string='version 21 subversion 0'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_args=''
config_argc=0
PERL_REVISION=5
-PERL_VERSION=20
-PERL_SUBVERSION=3
+PERL_VERSION=21
+PERL_SUBVERSION=0
PERL_API_REVISION=5
-PERL_API_VERSION=20
+PERL_API_VERSION=21
PERL_API_SUBVERSION=0
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
aphostname='/bin/hostname'
api_revision='5'
api_subversion='0'
-api_version='20'
-api_versionstring='5.20.0'
+api_version='21'
+api_versionstring='5.21.0'
ar='ar'
-archlib='/usr/lib/perl5/5.20.3/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.20.3/armv4l-linux'
+archlib='/usr/lib/perl5/5.21.0/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.21.0/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.20.3/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.0/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.20.3/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.21.0/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.20.3'
+installprivlib='./install_me_here/usr/lib/perl5/5.21.0'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.20.3/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.0/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.20.3'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.0'
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.20.3'
-privlibexp='/usr/lib/perl5/5.20.3'
+privlib='/usr/lib/perl5/5.21.0'
+privlibexp='/usr/lib/perl5/5.21.0'
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.20.3/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.20.3/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.21.0/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.21.0/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.20.3'
+sitelib='/usr/lib/perl5/site_perl/5.21.0'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.20.3'
+sitelibexp='/usr/lib/perl5/site_perl/5.21.0'
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='3'
+subversion='0'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.20.3'
-version_patchlevel_string='version 20 subversion 3'
+version='5.21.0'
+version_patchlevel_string='version 21 subversion 0'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_args=''
config_argc=0
PERL_REVISION=5
-PERL_VERSION=20
-PERL_SUBVERSION=3
+PERL_VERSION=21
+PERL_SUBVERSION=0
PERL_API_REVISION=5
-PERL_API_VERSION=20
+PERL_API_VERSION=21
PERL_API_SUBVERSION=0
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
the most important issues are listed below, but you should refer
to pod/perldelta.pod for more detailed information.
-B<WARNING:> This version is not binary compatible with versions of Perl
-earlier than 5.20.0.
+B<WARNING:> This version is not binary compatible with prior releases of Perl.
If you have built extensions (i.e. modules that include C code)
using an earlier version of Perl, you will need to rebuild and reinstall
those extensions.
=item Directories for the perl distribution
-By default, Configure will use the following directories for 5.20.3.
+By default, Configure will use the following directories for 5.21.0.
$version is the full perl version number, including subversion, e.g.
5.12.3, and $archname is a string like sun4-sunos,
determined by Configure. The full definitions of all Configure
=head1 Coexistence with earlier versions of perl 5
-Perl 5.20.3 is not binary compatible with versions of Perl earlier than 5.20.0.
+Perl 5.21.0 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 (e.g.
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.20.3
+ sh Configure -Dprefix=/opt/perl5.21.0
-and adding /opt/perl5.20.3/bin to the shell PATH variable. Such users
+and adding /opt/perl5.21.0/bin to the shell PATH variable. Such users
may also wish to add a symbolic link /usr/local/bin/perl so that
scripts can still start with #!/usr/local/bin/perl.
subversions may not have all the compatibility wrinkles ironed out
yet.
-=head2 Upgrading from 5.19.11 or earlier
+=head2 Upgrading from 5.19.0 or earlier
-B<Perl 5.20.3 may not be binary compatible with Perl 5.19.11 or
+B<Perl 5.21.0 may not be binary compatible with Perl 5.19.11 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.20.3. If you find you do need to rebuild an extension with
-5.20.3, you may safely do so without disturbing the older
+used with 5.21.0. If you find you do need to rebuild an extension with
+5.21.0, 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.20.3 is as follows (under $Config{prefix}):
+in Linux with perl-5.21.0 is as follows (under $Config{prefix}):
./bin/perl
- ./lib/perl5/5.20.3/strict.pm
- ./lib/perl5/5.20.3/warnings.pm
- ./lib/perl5/5.20.3/i686-linux/File/Glob.pm
- ./lib/perl5/5.20.3/feature.pm
- ./lib/perl5/5.20.3/XSLoader.pm
- ./lib/perl5/5.20.3/i686-linux/auto/File/Glob/Glob.so
+ ./lib/perl5/5.21.0/strict.pm
+ ./lib/perl5/5.21.0/warnings.pm
+ ./lib/perl5/5.21.0/i686-linux/File/Glob.pm
+ ./lib/perl5/5.21.0/feature.pm
+ ./lib/perl5/5.21.0/XSLoader.pm
+ ./lib/perl5/5.21.0/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 i386 version.
cpan/AutoLoader/t/02AutoSplit.t See if AutoSplit works
cpan/B-Debug/Debug.pm Compiler Debug backend
cpan/B-Debug/t/debug.t See if B::Debug works
-cpan/CGI/lib/CGI/Apache.pm Support for Apache's Perl module
-cpan/CGI/lib/CGI/Carp.pm Log server errors with helpful context
-cpan/CGI/lib/CGI/Cookie.pm Interface to Netscape Cookies
-cpan/CGI/lib/CGI/Fast.pm Support for FastCGI (persistent server process)
-cpan/CGI/lib/CGI.pm Web server interface ("Common Gateway Interface")
-cpan/CGI/lib/CGI/Pretty.pm Output nicely formatted HTML
-cpan/CGI/lib/CGI/Push.pm Support for server push
-cpan/CGI/lib/CGI/Switch.pm Simple interface for multiple server types
-cpan/CGI/lib/CGI/Util.pm Utility functions
-cpan/CGI/t/apache.t See if CGI::Apache still loads
-cpan/CGI/t/autoescape.t See if CGI.pm works
-cpan/CGI/t/can.t See if CGI.pm works
-cpan/CGI/t/carp.t See if CGI::Carp works
-cpan/CGI/t/charset.t See if CGI::Carp works
-cpan/CGI/t/checkbox_group.t See if CGI.pm works
-cpan/CGI/t/cookie.t See if CGI::Cookie works
-cpan/CGI/t/delete.t See if CGI.pm works
-cpan/CGI/t/Dump.t See if CGI->Dump works
-cpan/CGI/t/end_form.t See if CGI.pm works
-cpan/CGI/t/form.t See if CGI.pm works
-cpan/CGI/t/function.t See if CGI.pm works
-cpan/CGI/t/headers.t See if CGI.pm works
-cpan/CGI/t/hidden.t See if CGI.pm works
-cpan/CGI/t/html.t See if CGI.pm works
-cpan/CGI/t/http.t See if CGI.pm works
-cpan/CGI/t/init.t See if CGI.pm works
-cpan/CGI/t/init_test.txt See if CGI.pm works
-cpan/CGI/t/multipart_init.t See if CGI.pm works
-cpan/CGI/t/no_tabindex.t See if CGI.pm works
-cpan/CGI/t/param_fetch.t See if CGI pop menus work
-cpan/CGI/t/popup_menu.t See if CGI pop menus work
-cpan/CGI/t/pretty.t See if CGI.pm works
-cpan/CGI/t/push.t See if CGI::Push works
-cpan/CGI/t/query_string.t See if CGI->query_string() works
-cpan/CGI/t/request.t See if CGI.pm works
-cpan/CGI/t/rt-52469.t See if CGI.pm works
-cpan/CGI/t/save_read_roundtrip.t See if CGI.pm works
-cpan/CGI/t/start_end_asterisk.t See if CGI.pm works
-cpan/CGI/t/start_end_end.t See if CGI.pm works
-cpan/CGI/t/start_end_start.t See if CGI.pm works
-cpan/CGI/t/switch.t See if CGI::Switch still loads
-cpan/CGI/t/tmpdir.t See if CGI.pm works
-cpan/CGI/t/unescapeHTML.t See if CGI::unescapeHTML() works
-cpan/CGI/t/uploadInfo.t See if CGI.pm works
-cpan/CGI/t/upload_post_text.txt Test data for CGI.pm
-cpan/CGI/t/upload.t See if CGI.pm works
-cpan/CGI/t/url.t See if CGI.pm works
-cpan/CGI/t/user_agent.t See if CGI->user_agent() works
-cpan/CGI/t/utf8.t See if CGI.pm works
-cpan/CGI/t/util-58.t See if 5.8-dependent features work
-cpan/CGI/t/util.t See if CGI.pm works
cpan/Compress-Raw-Bzip2/bzip2-src/blocksort.c
cpan/Compress-Raw-Bzip2/bzip2-src/bzlib.c
cpan/Compress-Raw-Bzip2/bzip2-src/bzlib.h
cpan/Compress-Raw-Zlib/zlib-src/zutil.c Compress::Raw::Zlib
cpan/Compress-Raw-Zlib/zlib-src/zutil.h Compress::Raw::Zlib
cpan/Compress-Raw-Zlib/Zlib.xs Compress::Raw::Zlib
+cpan/Config-Perl-V/t/00_pod.t Config::Perl::V
+cpan/Config-Perl-V/t/01_pod.t Config::Perl::V
cpan/Config-Perl-V/t/10_base.t Config::Perl::V
-cpan/Config-Perl-V/t/20_plv56.t Config::Perl::V
-cpan/Config-Perl-V/t/21_plv58.t Config::Perl::V
-cpan/Config-Perl-V/t/22_plv510.t Config::Perl::V
-cpan/Config-Perl-V/t/23_plv512.t Config::Perl::V
-cpan/Config-Perl-V/t/24_plv514.t Config::Perl::V
-cpan/Config-Perl-V/t/25_plv5162.t Config::Perl::V
-cpan/Config-Perl-V/t/25_plv516.t Config::Perl::V
-cpan/Config-Perl-V/t/26_plv5182.t Config::Perl::V
-cpan/Config-Perl-V/t/26_plv518.t Config::Perl::V
-cpan/Config-Perl-V/t/27_plv5200.t Config::Perl::V
+cpan/Config-Perl-V/t/20_plv510.t Config::Perl::V
+cpan/Config-Perl-V/t/21_plv518.t Config::Perl::V
cpan/Config-Perl-V/V.pm Config::Perl::V
cpan/CPAN/lib/App/Cpan.pm helper package for CPAN.pm
cpan/CPAN/lib/CPAN/API/HOWTO.pod recipe book for programming with CPAN.pm
cpan/MIME-Base64/t/length.t See whether MIME::QuotedPrint works
cpan/MIME-Base64/t/quoted-print.t See whether MIME::QuotedPrint works
cpan/MIME-Base64/t/unicode.t See whether MIME::Base64 works
-cpan/Module-Build/bin/config_data
-cpan/Module-Build/lib/inc/latest.pm
-cpan/Module-Build/lib/inc/latest/private.pm
-cpan/Module-Build/lib/Module/Build/API.pod
-cpan/Module-Build/lib/Module/Build/Authoring.pod
-cpan/Module-Build/lib/Module/Build/Base.pm
-cpan/Module-Build/lib/Module/Build/Bundling.pod
-cpan/Module-Build/lib/Module/Build/Compat.pm
-cpan/Module-Build/lib/Module/Build/ConfigData.pm
-cpan/Module-Build/lib/Module/Build/Config.pm
-cpan/Module-Build/lib/Module/Build/Cookbook.pm
-cpan/Module-Build/lib/Module/Build/Dumper.pm
-cpan/Module-Build/lib/Module/Build/ModuleInfo.pm
-cpan/Module-Build/lib/Module/Build/Notes.pm
-cpan/Module-Build/lib/Module/Build/Platform/aix.pm
-cpan/Module-Build/lib/Module/Build/Platform/cygwin.pm
-cpan/Module-Build/lib/Module/Build/Platform/darwin.pm
-cpan/Module-Build/lib/Module/Build/Platform/Default.pm
-cpan/Module-Build/lib/Module/Build/Platform/MacOS.pm
-cpan/Module-Build/lib/Module/Build/Platform/os2.pm
-cpan/Module-Build/lib/Module/Build/Platform/Unix.pm
-cpan/Module-Build/lib/Module/Build/Platform/VMS.pm
-cpan/Module-Build/lib/Module/Build/Platform/VOS.pm
-cpan/Module-Build/lib/Module/Build/Platform/Windows.pm
-cpan/Module-Build/lib/Module/Build.pm
-cpan/Module-Build/lib/Module/Build/PodParser.pm
-cpan/Module-Build/lib/Module/Build/PPMMaker.pm
-cpan/Module-Build/lib/Module/Build/Version.pm
-cpan/Module-Build/lib/Module/Build/YAML.pm
-cpan/Module-Build/t/00-compile.t
-cpan/Module-Build/t/actions/installdeps.t
-cpan/Module-Build/t/actions/manifest_skip.t
-cpan/Module-Build/t/add_property_array.t
-cpan/Module-Build/t/add_property_hash.t
-cpan/Module-Build/t/add_property.t
-cpan/Module-Build/t/basic.t
-cpan/Module-Build/t/bundled/Software/License.pm
-cpan/Module-Build/t/bundled/Tie/CPHash.pm
-cpan/Module-Build/t/bundle_inc.t
-cpan/Module-Build/t/compat/exit.t
-cpan/Module-Build/t/compat.t
-cpan/Module-Build/t/debug.t
-cpan/Module-Build/t/destinations.t
-cpan/Module-Build/t/extend.t
-cpan/Module-Build/t/ext.t
-cpan/Module-Build/t/files.t
-cpan/Module-Build/t/help.t
-cpan/Module-Build/t/install_extra_target.t
-cpan/Module-Build/t/install.t
-cpan/Module-Build/t/lib/DistGen.pm
-cpan/Module-Build/t/lib/MBTest.pm
-cpan/Module-Build/t/lib/Module/Signature.pm
-cpan/Module-Build/t/lib/Software/License/VaporWare.pm
-cpan/Module-Build/t/manifypods.t
-cpan/Module-Build/t/manifypods_with_utf8.t
-cpan/Module-Build/t/metadata2.t
-cpan/Module-Build/t/metadata.t
-cpan/Module-Build/t/mymeta.t
-cpan/Module-Build/t/new_from_context.t
-cpan/Module-Build/t/notes.t
-cpan/Module-Build/t/parents.t
-cpan/Module-Build/t/perl_mb_opt.t
-cpan/Module-Build/t/PL_files.t
-cpan/Module-Build/t/pod_parser.t
-cpan/Module-Build/t/ppm.t
-cpan/Module-Build/t/properties/dist_suffix.t
-cpan/Module-Build/t/properties/license.t
-cpan/Module-Build/t/properties/module_name.t
-cpan/Module-Build/t/properties/needs_compiler.t
-cpan/Module-Build/t/properties/release_status.t
-cpan/Module-Build/t/properties/requires.t
-cpan/Module-Build/t/properties/share_dir.t
-cpan/Module-Build/t/README.pod
-cpan/Module-Build/t/resume.t
-cpan/Module-Build/t/runthrough.t
-cpan/Module-Build/t/sample.t
-cpan/Module-Build/t/script_dist.t
-cpan/Module-Build/t/test_file_exts.t
-cpan/Module-Build/t/test_reqs.t
-cpan/Module-Build/t/test_types.t
-cpan/Module-Build/t/test_type.t
-cpan/Module-Build/t/tilde.t
-cpan/Module-Build/t/unit_run_test_harness.t
-cpan/Module-Build/t/use_tap_harness.t
-cpan/Module-Build/t/versions.t
-cpan/Module-Build/t/write_default_maniskip.t
-cpan/Module-Build/t/xs.t
cpan/Module-Load-Conditional/lib/Module/Load/Conditional.pm Module::Conditional
cpan/Module-Load-Conditional/t/01_Module_Load_Conditional.t Module::Conditional tests
cpan/Module-Load-Conditional/t/test_lib/a/X.pm Module::Conditional tests
cpan/NEXT/t/next.t NEXT
cpan/NEXT/t/stringify.t NEXT
cpan/NEXT/t/unseen.t NEXT
-cpan/Package-Constants/lib/Package/Constants.pm Package::Constants
-cpan/Package-Constants/t/01_list.t Package::Constants tests
cpan/Params-Check/lib/Params/Check.pm Params::Check
cpan/Params-Check/t/01_Params-Check.t Params::Check tests
cpan/parent/lib/parent.pm Establish an ISA relationship with base classes at compile time
dist/Data-Dumper/t/purity_deepcopy_maxdepth.t See if three Data::Dumper functions work
dist/Data-Dumper/t/qr.t See if Data::Dumper works with qr|/|
dist/Data-Dumper/t/quotekeys.t See if Data::Dumper::Quotekeys works
-dist/Data-Dumper/t/recurse.t See if Data::Dumper::Maxrecurse works
dist/Data-Dumper/t/seen.t See if Data::Dumper::Seen works
dist/Data-Dumper/t/sortkeys.t See if Data::Dumper::Sortkeys works
dist/Data-Dumper/t/sparseseen.t See if Data::Dumper::Sparseseen works
pod/perl5180delta.pod Perl changes in version 5.18.0
pod/perl5181delta.pod Perl changes in version 5.18.1
pod/perl5182delta.pod Perl changes in version 5.18.2
-pod/perl5184delta.pod Perl changes in version 5.18.4
pod/perl5200delta.pod Perl changes in version 5.20.0
-pod/perl5201delta.pod Perl changes in version 5.20.1
-pod/perl5202delta.pod Perl changes in version 5.20.2
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
pod/perltoot.pod
pod/perltrap.pod Perl traps for the unwary
pod/perlunicode.pod Perl Unicode support
-pod/perlunicook.pod Perl Unicode cookbook
pod/perlunifaq.pod Perl Unicode FAQ
pod/perluniintro.pod Perl Unicode introduction
pod/perlunitut.pod Perl Unicode tutorial
t/op/while.t See if while loops work
t/op/write.t See if write works (formats work)
t/op/yadayada.t See if ... works
-t/perf/taint.t See if optimisations are keeping things fast (taint issues)
t/perl.supp Perl valgrind suppressions
t/porting/args_assert.t Check that all PERL_ARGS_ASSERT* macros are used
t/porting/authors.t Check that all authors have been acknowledged
t/porting/podcheck.t Test the POD of shipped modules is well formed
t/porting/pod_rules.t Check that various pod lists are consistent
t/porting/readme.t Check that all files in Porting/ are mentioned in Porting/README.pod
-t/porting/re_context.t Check assumptions made by save_re_context()
t/porting/regen.t Check that regen.pl doesn't need running
t/porting/ss_dup.t Check that sv.c:ss_dup handle everything
t/porting/test_bootstrap.t Test that the instructions for test bootstrapping aren't accidentally overlooked.
t/re/reg_pmod.t See if regexp /p modifier works as expected
t/re/reg_posixcc.t See if posix character classes behave consistently
t/re/re_tests Regular expressions for regexp.t
-t/re/rt122747.t Test rt122747 assert faile (requires DEBUGGING)
t/re/rxcode.t See if /(?{ code })/ works
t/re/subst_amp.t See if $&-related substitution works
t/re/subst.t See if substitution works
util.c Utility routines
util.h Dummy header
utils/c2ph.PL program to translate dbx stabs to perl
-utils/config_data.PL Module::Build tool
utils/corelist.PL Module::CoreList
utils/cpan.PL easily interact with CPAN from the command line
utils/enc2xs.PL Encode module generator
"vxs.inc"
]
},
- "release_status" : "stable",
+ "release_status" : "unstable",
"resources" : {
"bugtracker" : {
"web" : "https://rt.perl.org/"
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.020003"
+ "version" : "5.021000"
}
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.020003'
+version: '5.021000'
ndt_obj = $(obj0) $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
obj = $(ndt_obj) $(DTRACE_O)
-perltoc_pod_prereqs = extra.pods pod/perl5203delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl5210delta.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
# it on the target system if we're cross-compiling.
# If it is defined, then we just run it locally.
case "$hostgenerate" in
-''|'undef')
+'')
$spitshell >>$Makefile <<!GROK!THIS!
bitcount.h: generate_uudmap\$(HOST_EXE_EXT)
$run ./generate_uudmap\$(HOST_EXE_EXT) \$(generated_headers)
pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST
$(MINIPERL) pod/perlmodlib.PL -q
-pod/perl5203delta.pod: pod/perldelta.pod
- $(RMS) pod/perl5203delta.pod
- $(LNS) perldelta.pod pod/perl5203delta.pod
+pod/perl5210delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl5210delta.pod
+ $(LNS) perldelta.pod pod/perl5210delta.pod
extra.pods: $(MINIPERL_EXE)
-@test ! -f extra.pods || rm -f `cat extra.pods`
rm -rf pod/perlfunc pod/perlipc
-rmdir ext/B/lib
rm -f so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR)
- -rmdir lib/version lib/threads lib/inc/latest lib/inc lib/encoding
- -rmdir lib/autodie/exception lib/autodie lib/XS lib/Win32API lib/VMS
+ -rmdir lib/version lib/threads lib/encoding lib/autodie/exception
+ -rmdir lib/autodie lib/XS lib/Win32API lib/VMS
-rmdir lib/Unicode/Collate/Locale lib/Unicode/Collate/CJK
-rmdir lib/Unicode/Collate lib/Tie/Hash lib/Thread lib/Text
-rmdir lib/Test/Builder/Tester lib/Test/Builder lib/Test lib/Term
-rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Search
-rmdir lib/Scalar lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc
-rmdir lib/PerlIO/via lib/PerlIO lib/Perl lib/Parse/CPAN lib/Parse
- -rmdir lib/Params lib/Package lib/Net/FTP lib/Module/Load
- -rmdir lib/Module/CoreList lib/Module/Build/Platform lib/Module/Build
+ -rmdir lib/Params lib/Net/FTP lib/Module/Load lib/Module/CoreList
-rmdir lib/Module lib/Memoize lib/Math/BigInt lib/Math/BigFloat
-rmdir lib/Math lib/MIME lib/Locale/Maketext lib/Locale/Codes
-rmdir lib/Locale lib/List/Util lib/List lib/JSON/PP lib/JSON lib/IPC
-rmdir lib/Encode lib/Digest lib/Devel lib/Data lib/Config/Perl
-rmdir lib/Compress/Raw lib/Compress lib/Carp lib/CPAN/Meta
-rmdir lib/CPAN/LWP lib/CPAN/Kwalify lib/CPAN/HTTP lib/CPAN/FTP
- -rmdir lib/CPAN/Exception lib/CPAN/API lib/CPAN lib/CGI lib/Attribute
+ -rmdir lib/CPAN/Exception lib/CPAN/API lib/CPAN lib/Attribute
-rmdir lib/Archive/Tar lib/Archive lib/App/Prove/State/Result
-rmdir lib/App/Prove/State lib/App/Prove lib/App
$to cpan/*/t
$to dist/*/t
$to ext/*/t
- $to cpan/Archive-Tar/*
- $to cpan/Module-Metadata/*
$to cpan/Term-Cap/test.pl
$to cpan/Pod-Usage/*
$to cpan/Pod-Parser/*
$to *.h
# --- For t/x2p/s2p.t
$to x2p
-# --- For t/porting/customized.t
- $to vutil.c
- $to vxs.inc
# --- For t/TEST
$to config.sh
# --- For lib/diagnostics.t with -Duseshrplib
# Here comes the CW tools - TO BE FILLED TO BUILD WITH CW -
-MODULE_DESC = "Perl 5.20.3 for NetWare"
+MODULE_DESC = "Perl 5.21.0 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.20.3
+INST_VER = \5.21.0
#
# Comment this out if you DON'T want your perl installation to have
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define ARCHLIB "c:\\perl\\5.20.3\\lib\\NetWare-x86-multi-thread" /**/
+#define ARCHLIB "c:\\perl\\5.21.0\\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.20.3\\bin\\NetWare-x86-multi-thread" /**/
-#define BIN_EXP "c:\\perl\\5.20.3\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN "c:\\perl\\5.21.0\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN_EXP "c:\\perl\\5.21.0\\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.20.3\\lib\\NetWare-x86-multi-thread" /**/
+#define SITEARCH "c:\\perl\\site\\5.21.0\\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.20.3\\lib" /**/
+#define SITELIB "c:\\perl\\site\\5.21.0\\lib" /**/
/*#define SITELIB_EXP "" /**/
#define SITELIB_STEM "" /**/
'FILES' => q[dist/Carp],
},
- 'CGI' => {
- 'DISTRIBUTION' => 'MARKSTOS/CGI.pm-3.65.tar.gz',
- 'FILES' => q[cpan/CGI],
- 'EXCLUDED' => [
- qr{^examples/},
- qw( cgi_docs.html
- t/gen-tests/gen-start-end-tags.pl
- t/fast.t
- ),
- ],
- 'DEPRECATED' => '5.019007',
- },
-
'Compress::Raw::Bzip2' => {
'DISTRIBUTION' => 'PMQS/Compress-Raw-Bzip2-2.064.tar.gz',
'FILES' => q[cpan/Compress-Raw-Bzip2],
},
'Config::Perl::V' => {
- 'DISTRIBUTION' => 'HMBRAND/Config-Perl-V-0.22.tgz',
+ 'DISTRIBUTION' => 'HMBRAND/Config-Perl-V-0.20.tgz',
'FILES' => q[cpan/Config-Perl-V],
- 'EXCLUDED' => [qw(
- examples/show-v.pl
- t/00_pod.t
- t/01_pod.t
- )],
+ 'EXCLUDED' => ['examples/show-v.pl'],
},
'constant' => {
t/yaml_code.yml
),
],
- # Waiting to be merged upstream: see pull request #83
- 'CUSTOMIZED' => [
- qw( lib/CPAN/Author.pm
- lib/CPAN/CacheMgr.pm
- lib/CPAN/FTP.pm
- lib/CPAN/HTTP/Client.pm
- lib/CPAN/HandleConfig.pm
- lib/CPAN/Index.pm
- lib/CPAN/LWP/UserAgent.pm
- lib/CPAN/Mirrors.pm
- ),
- ],
},
# Note: When updating CPAN-Meta the META.* files will need to be regenerated
'EXCLUDED' => ['t/bad-sv.t'],
},
- #
- # To update Module-Build in blead see
- # https://github.com/Perl-Toolchain-Gang/Module-Build/blob/master/devtools/patching_blead.pod
- #
-
- 'Module::Build' => {
- 'DISTRIBUTION' => 'LEONT/Module-Build-0.4205.tar.gz',
- 'FILES' => q[cpan/Module-Build],
- 'EXCLUDED' => [
- qw( t/par.t
- t/signature.t
- ),
- qr{^contrib/},
- qr{^inc},
- ],
- # Generated file, not part of the CPAN distro:
- 'CUSTOMIZED' => ['lib/Module/Build/ConfigData.pm'],
- 'DEPRECATED' => '5.019000',
- },
-
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20150720.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-3.10.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
'EXCLUDED' => [qr{^demo/}],
},
- 'Package::Constants' => {
- 'DISTRIBUTION' => 'BINGOS/Package-Constants-0.04.tar.gz',
- 'FILES' => q[cpan/Package-Constants],
- 'DEPRECATED' => '5.019006',
- },
-
'Params::Check' => {
'DISTRIBUTION' => 'BINGOS/Params-Check-0.38.tar.gz',
'FILES' => q[cpan/Params-Check],
'Pod::Parser' => {
'DISTRIBUTION' => 'MAREKR/Pod-Parser-1.62.tar.gz',
'FILES' => q[cpan/Pod-Parser],
- # Waiting to be merged upstream: see CPAN RT#101847
- 'CUSTOMIZED' => [ qw( lib/Pod/PlainText.pm) ],
},
'Pod::Perldoc' => {
},
'version' => {
- 'DISTRIBUTION' => 'JPEACOCK/version-0.9909.tar.gz',
+ 'DISTRIBUTION' => 'JPEACOCK/version-0.9908.tar.gz',
'FILES' => q[cpan/version vutil.c vutil.h vxs.inc],
'EXCLUDED' => [
qr{^vutil/lib/},
'CUSTOMIZED' => [
qw( lib/version.pm
),
+
+ # Merged upstream, waiting for new CPAN release: see CPAN RT#92721
+ qw( vutil.c
+ vxs.inc
+ ),
],
'MAP' => {
ken\100mathforum.org kenahoo\100gmail.com
+ ken.williams\100thomsonreuters.com
kentfredric\100gmail.com kentnl\100cpan.org
-kmx\100volny.cz kmx\100volny.cz
-+ kmx\100cpan.org
kroepke\100dolphin-services.de kay\100dolphin-services.de
kst\100mib.org kst\100cts.com
+ kst\100SDSC.EDU
tjenness\100cpan.org t.jenness\100jach.hawaii.edu
+ timj\100jach.hawaii.edu
tobez\100tobez.org tobez\100plab.ku.dk
-toddr\100cpan.org toddr\100cpanel.net
+toddr\100cpanel.net toddr\100cpan.org
tom\100compton.nu thh\100cyberscience.com
tom.horsley\100mail.ccur.com tom.horsley\100ccur.com
+ tom\100amber.ssd.hcsc.com
$check = `git describe --abbrev=0 $check 2>$null`;
chomp $check;
last unless $check =~ /-RC/;
- $check .= '~1';
+ $check .= '^';
}
$tag_to_compare = $check;
# Thanks to David Golden for this suggestion.
@skip{
'cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/BFD.pm', # just a test module
'cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/XS.pm', # just a test module
- 'cpan/Module-Build/t/lib/DistGen.pm', # just a test module
- 'cpan/Module-Build/t/lib/MBTest.pm', # just a test module
- 'cpan/Module-Metadata/t/lib/DistGen.pm', # just a test module
- 'cpan/Module-Metadata/t/lib/MBTest.pm', # just a test module
- 'cpan/Module-Metadata/t/lib/Tie/CPHash.pm', # just a test module
'dist/Attribute-Handlers/demo/MyClass.pm', # it's just demonstration code
'dist/Exporter/lib/Exporter/Heavy.pm',
'lib/Carp/Heavy.pm',
# look for a .pm in lib/ based on that:
my ($path) = shift =~ m!^(.*)/!;
my ($last) = $path =~ m!([^/]+)\z!;
- $last = 'List-Util' if $last eq 'Scalar-List-Utils';
$last =~ tr !-!/!;
return "$path/lib/$last";
}) {
and grep $pm_version eq $_, @{$skip_versions{$pm_file}}) {
print "ok $count - SKIP $pm_file version $pm_version\n";
} else {
- print "not ok $count - $pm_file version $pm_version\n";
+ print "not ok $count - $pm_file\n";
}
} else {
push @diff, @{$module_diffs{$pm_file}};
- print "$pm_file version $pm_version\n";
+ print "$pm_file\n";
}
}
}
aphostname='/bin/hostname'
api_revision='5'
api_subversion='0'
-api_version='20'
-api_versionstring='5.20.0'
+api_version='21'
+api_versionstring='5.21.0'
ar='ar'
-archlib='/pro/lib/perl5/5.20.3/i686-linux-64int'
-archlibexp='/pro/lib/perl5/5.20.3/i686-linux-64int'
+archlib='/pro/lib/perl5/5.21.0/i686-linux-64int'
+archlibexp='/pro/lib/perl5/5.21.0/i686-linux-64int'
archname64='64int'
archname='i686-linux-64int'
archobjs=''
incpth='/usr/lib/gcc/i586-suse-linux/4.8/include /usr/local/include /usr/lib/gcc/i586-suse-linux/4.8/include-fixed /usr/lib/gcc/i586-suse-linux/4.8/../../../../i586-suse-linux/include /usr/include'
inews=''
initialinstalllocation='/pro/bin'
-installarchlib='/pro/lib/perl5/5.20.3/i686-linux-64int'
+installarchlib='/pro/lib/perl5/5.21.0/i686-linux-64int'
installbin='/pro/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='/pro/local/man/man3'
installprefix='/pro'
installprefixexp='/pro'
-installprivlib='/pro/lib/perl5/5.20.3'
+installprivlib='/pro/lib/perl5/5.21.0'
installscript='/pro/bin'
-installsitearch='/pro/lib/perl5/site_perl/5.20.3/i686-linux-64int'
+installsitearch='/pro/lib/perl5/site_perl/5.21.0/i686-linux-64int'
installsitebin='/pro/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='/pro/lib/perl5/site_perl/5.20.3'
+installsitelib='/pro/lib/perl5/site_perl/5.21.0'
installsiteman1dir='/pro/local/man/man1'
installsiteman3dir='/pro/local/man/man3'
installsitescript='/pro/bin'
perl_static_inline='static __inline__'
perladmin='hmbrand@cpan.org'
perllibs='-lnsl -ldl -lm -lcrypt -lutil -lc'
-perlpath='/pro/bin/perl5.20.3'
+perlpath='/pro/bin/perl5.21.0'
pg='pg'
phostname='hostname'
pidtype='pid_t'
pr=''
prefix='/pro'
prefixexp='/pro'
-privlib='/pro/lib/perl5/5.20.3'
-privlibexp='/pro/lib/perl5/5.20.3'
+privlib='/pro/lib/perl5/5.21.0'
+privlibexp='/pro/lib/perl5/5.21.0'
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, 64, 6, 17, 29, 31, 0'
sig_size='69'
signal_t='void'
-sitearch='/pro/lib/perl5/site_perl/5.20.3/i686-linux-64int'
-sitearchexp='/pro/lib/perl5/site_perl/5.20.3/i686-linux-64int'
+sitearch='/pro/lib/perl5/site_perl/5.21.0/i686-linux-64int'
+sitearchexp='/pro/lib/perl5/site_perl/5.21.0/i686-linux-64int'
sitebin='/pro/bin'
sitebinexp='/pro/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/pro/lib/perl5/site_perl/5.20.3'
+sitelib='/pro/lib/perl5/site_perl/5.21.0'
sitelib_stem='/pro/lib/perl5/site_perl'
-sitelibexp='/pro/lib/perl5/site_perl/5.20.3'
+sitelibexp='/pro/lib/perl5/site_perl/5.21.0'
siteman1dir='/pro/local/man/man1'
siteman1direxp='/pro/local/man/man1'
siteman3dir='/pro/local/man/man3'
ssizetype='ssize_t'
st_ino_sign='1'
st_ino_size='8'
-startperl='#!/pro/bin/perl5.20.3'
+startperl='#!/pro/bin/perl5.21.0'
startsh='#!/bin/sh'
static_ext=' '
stdchar='char'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='3'
+subversion='0'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.20.3'
-version_patchlevel_string='version 20 subversion 3'
+version='5.21.0'
+version_patchlevel_string='version 21 subversion 0'
versiononly='define'
vi=''
xlibpth='/usr/lib/386 /lib/386'
zcat=''
zip='zip'
PERL_REVISION=5
-PERL_VERSION=20
-PERL_SUBVERSION=3
+PERL_VERSION=21
+PERL_SUBVERSION=0
PERL_API_REVISION=5
-PERL_API_VERSION=20
+PERL_API_VERSION=21
PERL_API_SUBVERSION=0
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.20.3/i686-linux-64int-ld" /**/
-#define ARCHLIB_EXP "/pro/lib/perl5/5.20.3/i686-linux-64int-ld" /**/
+#define ARCHLIB "/pro/lib/perl5/5.21.0/i686-linux-64int-ld" /**/
+#define ARCHLIB_EXP "/pro/lib/perl5/5.21.0/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.20.3" /**/
-#define PRIVLIB_EXP "/pro/lib/perl5/5.20.3" /**/
+#define PRIVLIB "/pro/lib/perl5/5.21.0" /**/
+#define PRIVLIB_EXP "/pro/lib/perl5/5.21.0" /**/
/* 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.20.3/i686-linux-64int-ld" /**/
-#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.20.3/i686-linux-64int-ld" /**/
+#define SITEARCH "/pro/lib/perl5/site_perl/5.21.0/i686-linux-64int-ld" /**/
+#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.0/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.20.3" /**/
-#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.20.3" /**/
+#define SITELIB "/pro/lib/perl5/site_perl/5.21.0" /**/
+#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.0" /**/
#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.20.3" /**/
+#define STARTPERL "#!/pro/bin/perl5.21.0" /**/
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
my $corelist_file = 'dist/Module-CoreList/lib/Module/CoreList.pm';
my $utils_file = 'dist/Module-CoreList/lib/Module/CoreList/Utils.pm';
+my $pod_file = 'dist/Module-CoreList/lib/Module/CoreList.pod';
my %lines;
my %module_to_file;
write_corelist($corelist,$corelist_file);
+open( my $pod_fh, '<', $pod_file );
+my $pod = join( '', <$pod_fh> );
+
+unless ( $pod =~ /and $perl_vstring releases of perl/ ) {
+ warn "Adding $perl_vstring to the list of perl versions covered by Module::CoreList\n";
+ $pod =~ s/(currently\s+covers\s+(?:.*?))\s*and\s+(.*?)\s+releases\s+of\s+perl/$1, $2 and $perl_vstring releases of perl/ism;
+}
+
+write_corelist($pod,$pod_file);
+
open( my $utils_fh, '<', $utils_file );
my $utils = join( '', <$utils_fh> );
close $utils_fh;
write_corelist($utils,$utils_file);
warn "All done. Please check over the following files carefully before committing.\nThanks!\n";
-warn "$corelist_file\n$utils_file\n";
+warn "$corelist_file\n$pod_file\n$utils_file\n";
sub write_corelist {
my $content = shift;
=head1 EPIGRAPHS
-=head2 v5.20.3-RC2 - Anon., trans. Malcolm C. Lyons, "The Story of Abu Muhammad the Idle and the Marvels He Encountered with the Ape As Well As the Marvels of the Seas and Islands", from "Tales of the Marvellous and News of the Strange"
-
-L<Announced on 2015-08-29 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2015/08/msg230544.html>
-
-'I fled from Basra, sad and tearful, with no idea where I was going,
-and I was reciting these lines:
-
- The pain of parting makes me melt away,
- As lovers do when those they love are harsh.
- I wonder at the patience that I showed
- When I had lost my love, for that was wonderful.
- Beloved, do you know that since you left,
- I have remained confused in misery.
-
-I then heard a voice that said: "Damn you, have you no fear of
-Almighty God that you hand over a girl to an unbelieving 'ifrit?" I
-walked for a time amongst the palm-trees until I caught sight of a
-person, whom I approached. When I asked him who he was he said: "I
-am one of the jinn who were converted to Islam at the hands of 'Ali
-ibn Abi Talib, may God ennoble him." "How can I get to my wife?" I
-asked him, and he said: "Wretched fellow, you had a bird which you
-allowed to fly away and now you want to fly after it." But he
-added: "Follow this road with God's blessing all night until dawn
-and then by the shore you will see a huge cave in which there is an
-idol made of white stone. You must drink of the water that there is
-coming out of the cave and smear your face with its mud. Stay there
-and a barge will pass you as you stand opposite the statue. Various
-different creatures will emerge, heads without bodies and bodies
-without heads, and they will prostrate themselves in adoration to
-the idol rather than to Almighty God. When you see that, embark on
-the barge and cross to the other bank and walk along it until
-sunset. On a high point you will see a castle built of bricks of
-gold and silver. That is where your 'ifrit will be. I have now
-told you about this, so goodbye."
-
-=head2 v5.20.3-RC1 - Anon., trans. Malcolm C. Lyons, "The Story of Abu Muhammad the Idle and the Marvels He Encountered with the Ape As Well As the Marvels of the Seas and Islands", from "Tales of the Marvellous and News of the Strange"
-
-L<Announced on 2015-08-22 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2015/08/msg230359.html>
-
-'On the night of the wedding the ape came to sit in front of me and
-asked me what I intended to do. "Whatever you tell me," I replied,
-and he said: "Take care not to covet the girl, or I shall come back
-and burn you up and leave you as a lesson for those who can learn."
-I agreed to this and when evening came I found the world full of
-candles and torches burning in holders of gold and silver. There
-were servants and serving girls, and everyone who saw me
-congratulated me on my good fortune, as there was no girl on the
-face of the earth more beautiful than my bride.
-[...]
-'Next morning I went out to the market, and people went in and asked
-her how the night had been. "He never looked up at me," she told
-them. Then, when it was afternoon, I went to my house, where the
-ape was sitting by the door. "Tell me what you did," it said, and I
-told it: "By God, I did not learn and do not know whether this was a
-man or a girl." "That's what I want," it said.
-[...]
-'On the second night my bride was brought to me, after which the
-servants left her and went away. She fell asleep, and, while she
-was sleeping, I killed the cock, wrapped it in the cloth and put the
-four poles from the couch over it. Suddenly there was a huge crash
-like a peal of thunder and a fiery 'ifrit swooped on the girl. I
-fainted at the sight and when I recovered I heard a voice saying:
-"By the Lord of the Ka'ba, the girl has been carried off!" and there
-was a sound like the rustling of wind and bitter weeping. At this I
-shed tears, struck my head and was filled with regret when it was no
-longer of any use, for to me the whole world was worth no more than
-a bean.
-
-=head2 v5.23.2 - Blind Guardian, "Skalds and Shadows"
-
-L<Announced on 2015-08-20 by Matthew Horsfall|http://www.nntp.perl.org/group/perl.perl5.porters/2015/08/msg230298.html>
-
- Would you believe in a night like this
- A night like this, when visions come true
- Would you believe in a tale like this
- A lay of bliss, praise in the old lore
- Come to the blazing fire and
-
- See me in the shadows
- See me in the shadows
- Songs I will sing
- Of runes and rings
- Just hand me my harp
- This night turns into myth
- Nothing seems real
- You soon will feel
- The world we live in is another skald's
- Dream in the shadows
- Dream in the shadows
-
- Do you believe there is sense in it
- Is it truth or myth?
- They´re one in my rhymes
- Nobody knows the meaning behind
- The weaver's line
- Well nobody else but the Norns can
- See through the blazing fires of time and
- All things will proceed as the
- Child of the hallowed
- Will speak to you now
-
- See me in the shadows
- See me in the shadows
- Songs I will sing of tribes and kings
- The carrion bird and the hall of the slain
- Nothing seems real
- You soon will feel
- The world we live in is another skald´s
- Dream in the shadows
- Dream in the shadows
-
- Do not fear for my reason
- There's nothing to hide
- How bitter your treason
- How bitter the lie
- Remember the runes and remember the light
- All I ever want is to be at your side
- We'll gladden the raven now I will
- Run through the blazing fires
- That's my choice
- Cause things shall proceed as foreseen
-
-=head2 v5.23.1 - Elizabeth Haydon, "The Assassin King"
-
-L<Announced on 2015-07-20 by Matthew Horsfall|http://www.nntp.perl.org/group/perl.perl5.porters/2015/07/msg229413.html>
-
- I was born beneath this willow,
- Where my sire the earth did farm
- Had the green grass as my pillow
- The east wind as a blanket warm.
-
- But away! away! called the wind from the west
- And in answer I did run
- Seeking glory and adventure
- Promised by the rising sun.
-
- I found love beneath this willow,
- As true a love as life could hold,
- Pledged my heart and swore my fealty
- Sealed with a kiss and a band of gold.
-
- But to arms! to arms! called the wind from the west
- In faithful answer I did run
- Marching forth for king and country
- In battles 'neath the midday sun.
-
- Oft I dreamt of that fair willow
- As the seven seas I plied
- And the girl who I left waiting
- Longing to be at her side.
-
- But about! about! called the wind from the west
- As once again my ship did run
- Down the coast, about the wide world
- Flying sails in the setting sun.
-
- Now I lie beneath the willow
- Now at last no more to roam,
- My bride and earth so tightly hold me
- In their arms I'm finally home.
-
- While away! away! calls the wind from the west
- Beyond the grave my spirit, free
- Will chase the sun into the morning
- Beyond the sky, beyond the sea.
-
-=head2 v5.23.0 - Bob Dylan, Maggie's Farm
-
-L<Announced on 2015-06-20 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2015/06/msg228807.html>
-
- I ain't gonna work on Maggie's farm no more
- I ain't gonna work on Maggie's farm no more
- Well, I try my best
- To be just like I am
- But everybody wants you
- To be just like them
- They sing while you slave and I just get bored
- I ain't gonna work on Maggie's farm no more
-
-=head2 v5.22.0 - Gene Wolfe, The Citadel of the Autarch
-
-L<Announced on 2015-06-01 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2015/06/msg228300.html>
-
-“You are the advocate of the dead.”
-
-The old man nodded. “I am. People talk about being fair to this one and
-that one, but nobody I ever heard talks about doing right by them. We
-take everything they had, which is all right. And spit, most often, on
-their opinions, which I suppose is all right too. But we ought to
-remember now and then how much of what we have we got from them. I
-figure while I’m still here I ought to put a word in for them.”
-
-=head2 v5.22.0-RC2 - T.S. Eliot, unpublished work
-
-L<Announced on 2015-05-21 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2015/05/msg228142.html>
-
- And when thyself with silver foot shall pass
- Among the theories scattered on the grass
- Take up my good intentions with the rest
-
-=head2 v5.22.0-RC1 - Gene Wolfe, Citadel of the Autarch
-
-L<Announced on 2015-05-19 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2015/05/msg228059.html>
-
-There is no limit to stupidity. Space itself is said to be bounded by
-its own curvature, but stupidity continues beyond infinity.
-
-=head2 v5.21.11 - Algernon Charles Swinburne, "Dolores (Notre-Dame des Sept Douleurs)"
-
-L<Announced on 2015-04-20 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2015/04/msg227472.html>
-
- They shall pass and their places be taken,
- The gods and the priests that are pure.
- They shall pass, and shalt thou not be shaken?
- They shall perish, and shalt thou endure?
- Death laughs, breathing close and relentless
- In the nostrils and eyelids of lust,
- With a pinch in his fingers of scentless
- And delicate dust.
-
- But the worm shall revive thee with kisses;
- Thou shalt change and transmute as a god,
- As the rod to a serpent that hisses,
- As the serpent again to a rod.
- Thy life shall not cease though thou doff it;
- Thou shalt live until evil be slain,
- And good shall die first, said thy prophet,
- Our Lady of Pain.
-
-=head2 v5.21.10 - Aldous Huxley, "The Devils of Loudun"
-
-L<Announced on 2015-03-20 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2015/03/msg226847.html>
-
-The fire burned on, the good fathers continued to sprinkle and intone.
-Suddenly a flock of pigeons came swooping down from the church and
-started to wheel around the roaring column of flame and smoke. The
-crowd shouted, the archers waved their halberds at the birds, Lactance
-and Tranquille splashed them on the wing with holy water. In vain. The
-pigeons were not to be driven away. Round and round they flew, diving
-through the smoke, singeing their feathers in the flames. Both parties
-claimed a miracle. For the parson's enemies the birds, quite obviously,
-were a troop of devils, come to fetch away his soul. For his friends,
-they were emblems of the Holy Ghost and living proof of his innocence.
-It never seems to have occurred to anyone that they were just pigeons,
-obeying the laws of their own, their blessedly other-than-human nature.
-
-=head2 v5.21.9 - Emily Dickinson, "There is Another Sky"
-
-L<Announced on 2015-02-20 by Sawyer X|http://www.nntp.perl.org/group/perl.perl5.porters/2015/02/msg226002.html>
-
-There is another sky,
-Ever serene and fair,
-And there is another sunshine,
-Though it be darkness there;
-Never mind faded forests, Austin,
-Never mind silent fields -
-Here is a little forest,
-Whose leaf is ever green;
-Here is a brighter garden,
-Where not a frost has been;
-In its unfading flowers
-I hear the bright bee hum:
-Prithee, my brother,
-Into my garden come!
-
-=head2 v5.20.2 - Jonathan "Jonti" Picking, L<"Magical Trevor"|http://www.weebls-stuff.com/other-toons/video/magical-trevor.html>
-
-L<Announced on 2015-02-14 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2015/02/msg225777.html>
-
- Everyone loves Magical Trevor,
- 'Cos the tricks that he does are ever so clever;
- Look at him now, disappearin' the cow,
- Where is the cow hidden right now?
-
- Taking a bow, it's Magical Trevor,
- Everybody's seen that the trick is clever;
- Look at him there with his leathery, leathery whip!
- It's made of magic, and with a little flip--
-
- Yeah, yeah, yeah, the cow is back,
- Yeah, yeah, yeah, the cow is back;
- Back, back, back from his magical journey,
- Yeah!
-
- What did he see in the parallel dimension?
- He saw beans, lots of beans, lots of beans, lots of beans;
- Oh, beans, lots of beans, lots of beans, lots of beans,
- Yeah, yeah!
-
-=head2 v5.20.2-RC1 - Jonathan "Jonti" Picking, L<"Scampi"|http://www.weebls-stuff.com/other-toons/video/scampi.html>
-
-L<Announced on 2015-02-01 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2015/02/msg225273.html>
-
- I've seen things,
- I've seen them with my eyes;
- I've seen things,
- They're often in disguise.
-
- Like carrots, handbags, cheese, toilets,
- Russians, planets, hamsters, weddings,
- Poets, Stalin, Kuala Lumpur!
- Pygmies, budgies, Kuala Lumpur!
-
- I've seen things,
- I've seen them with my eyes;
- I've seen things,
- They're often in disguise.
-
- Like carrots, handbags, cheese...
-
-=head2 v5.21.8 - Bill Watterson, "Scientific Progress Goes 'Boink': A Calvin and Hobbes Collection"
-
-L<Announced on 2015-01-20 by Matthew Horsfall|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg224869.html>
-
-Calvin: OK Hobbes, press the button and duplicate me.
-Hobbes: Are you sure this is such a good idea?
-Calvin: Brother! You doubting Thomases get in the way of more scientific advances with your stupid ethical questions! This is a *BRILLIANT* idea! Hit the button, will ya?
-Hobbes: I'd hate to be accused of inhibiting scientific progress... Here you go.
-[Box]: *BOINK*
-Hobbes: Scientific progress goes "BOINK"?
-Calvin?: It worked! It worked! I'm a genius!
-Cavlin??: No you're not, you liar! *I* invented this!
-
-=head2 v5.21.7 - Robert Heinlein, The Number of the Beast
-
-L<Announced on 2014-12-20 by Max Maischein|http://www.nntp.perl.org/group/perl.perl5.porters/2014/12/msg223774.html>
-
- "Zebadiah, Hilda and I salvaged and put everything into the basket.
- Hilda started to put it into our wardrobe-and it was heavy. So
- we looked. Packed as tight as when we left Oz. Six bananas-and
- everything else. Cross my heart. No, go look."
- "Hmmm- Jake, can you write equations for a picnic basket that
- refills itself? Will it go on doing so?"
- "Zeb, equations can be written to describe anything. The description
- would be simpler for a basket that replenishes itself indefinitely
- than for one that does it once and stops-I would have to describe
- the discontinuity."
-
-=head2 v5.21.6 - Jeff Noon, Vurt
-
-L<Announced on 2014-11-20 by Chris 'BinGOs' Williams|http://www.nntp.perl.org/group/perl.perl5.porters/2014/11/msg222448.html>
-
- GAME CAT
-
- EXCHANGE MECHANISMS. Sometimes we lose precious
- things. Friends and colleagues, fellow travellers in the
- Vurt, sometimes we lose them; even lovers we sometimes
- lose. And get bad things in exchange: aliens, objects,
- snakes, and sometimes even death. Things we don't want.
- This is part of the deal, part of the game deal;
- all things, in all worlds, must be kept in balance.
- Kittlings often ask, who decides on the swappings? Now then,
- some say it's all accidental; that some poor Vurt thing
- finds himself too close to a door, at too critical a time,
- just when something real is being lost. Whoosh! Swap time!
- Others say that some kind of overseer is working the
- MECHANISMS OF EXCHANGE, deciding the fate of innocents.
- The Cat can only tease at this, because of the big secrets
- involved, and because of the levels between you, the reader,
- and me, the Game Cat. Hey, listen; I've struggled to get
- where I am today; why should I give you the easy route?
- Get working, kittlings! Reach up higher. Work the Vurt.
-
-=head2 v5.21.5 - Friso Wiegersma (text), Jean Ferrat (music), Wim Sonneveld (performer), Het Dorp
-
-L<Announced on 2014-10-20 by Abigail|http://www.nntp.perl.org/group/perl.perl5.porters/2014/10/msg221399.html>
-
- Het Dorp
-
- Thuis heb ik nog een ansichtkaart
- waarop een kerk, een kar met paard,
- een slagerij J. van der Ven.
- Een kroeg, een juffrouw op de fiets
- het zegt u hoogstwaarschijnlijk niets,
- maar 't is waar ik geboren ben.
- Dit dorp, ik weet nog hoe het was,
- de boerenkind'ren in de klas,
- een kar die ratelt op de keien,
- het raadhuis met een pomp ervoor,
- een zandweg tussen koren door,
- het vee, de boerderijen.
-
- En langs het tuinpad van m'n vader
- zag ik de hoge bomen staan.
- Ik was een kind en wist niet beter,
- dan dat dat nooit voorbij zou gaan.
-
- Wat leefden ze eenvoudig toen
- in simp'le huizen tussen groen
- met boerenbloemen en een heg.
- Maar blijkbaar leefden ze verkeerd,
- het dorp is gemoderniseerd
- en nu zijn ze op de goeie weg.
- Want ziet, hoe rijk het leven is,
- ze zien de televisiequiz
- en wonen in betonnen dozen,
- met flink veel glas, dan kun je zien
- hoe of het bankstel staat bij Mien
- en d'r dressoir met plastic rozen.
-
- En langs het tuinpad van m'n vader
- zag ik de hoge bomen staan.
- Ik was een kind en wist niet beter,
- dan dat dat nooit voorbij zou gaan.
-
- De dorpsjeugd klit wat bij elkaar
- in minirok en beatle-haar
- en joelt wat mee met beat-muziek.
- Ik weet wel, het is hun goeie recht,
- de nieuwe tijd, net wat u zegt,
- maar het maakt me wat melancholiek.
- Ik heb hun vaders nog gekend
- ze kochten zoethout voor een cent
- ik zag hun moeders touwtjespringen.
- Dat dorp van toen, het is voorbij,
- dit is al wat er bleef voor mij:
- een ansicht en herinneringen.
-
- Toen ik langs het tuinpad van m'n vader
- de hoge bomen nog zag staan.
- Ik was een kind, hoe kon ik weten
- dat dat voorgoed voorbij zou gaan.
-
-=head2 v5.21.4 - Edgar Allan Poe, The Narrative of Arthur Gordon Pym of Nantucket
-
-L<Announced on 2014-09-20 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/09/msg220267.html>
-
- To-day, being in latitude 83° 20', longitude 43° 5' W. (the sea being
- of an extraordinarily dark colour), we again saw land from the
- masthead, and, upon a closer scrutiny, found it to be one of a group
- of very large islands. The shore was precipitous, and the interior
- seemed to be well wooded, a circumstance which occasioned us great
- joy. In about four hours from our first discovering the land we came
- to anchor in ten fathoms, sandy bottom, a league from the coast, as a
- high surf, with strong ripples here and there, rendered a nearer
- approach of doubtful expediency. The two largest boats were now
- ordered out, and a party, well armed (among whome were Peters and
- myself), proceeded to look for an opening in the reef which appeared
- to encircle the island. After searching about for some time, we
- discovered an inlet, which we were entering, when we saw four large
- canoes put off from the shore, filled with men who seemed to be well
- armed. We waited for them to come up, and, as they moved with great
- rapidity, they were soon within hail. Captain Guy now held up a white
- handkerchief on the blade of an oar, when the strangers made a full
- stop, and commenced a loud jabbering all at once, intermingled with
- occasional shouts, in which we could distinguish the words Anamoo-moo!
- and Lama-Lama! They continued this for at least half an hour, during
- which we had a good opportunity of observing their appearance.
-
-=head2 v5.20.1 - Lorenzo da Ponte, Così fan tutte
-
-L<Announced on 2014-09-14 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/09/msg219789.html>
-
- DORABELLA (as if waking from a daze): Where are they?
- DON ALFONSO: They've gone.
- FIORDILIGI: Oh, the cruel bitterness of parting!
-
- DON ALFONSO:
- Take heart, my dearest children.
- Look, in the distance, your lovers are waving to you.
-
- FIORDILIGI: Bon voyage, my darling!
- DORABELLA: Bon voyage!
-
- FIORDILIGI:
- O heavens! How swiftly the ship is sailing away!
- It is disappearing already!
- It is no longer in sight!
- Oh, may heaven grant it a prosperous voyage!
-
- DORABELLA: May good luck attend it to the battlefield!
- DON ALFONSO: And may your sweethearts and my friends be safe!
-
- FIORDILIGI, DORABELLA, DON ALFONSO:
- May the wind be gentle,
- may the sea be calm,
- and may the elements
- respond kindly
- to our wishes.
-
- -- Lorenzo da Ponte, /Così fan tutte/,
- trans. Diana Reed
-
-=head2 v5.20.1-RC2 - Lorenzo da Ponte, Così fan tutte
-
-L<Announced on 2014-09-07 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/09/msg219446.html>
-
- GUGLIELMO:
- Oh God, I feel that this foot of mine
- is reluctant to come before her.
-
- FERRANDO:
- My trembling lip
- can utter no word.
-
- DON ALFONSO:
- The hero displays his manliness
- in the most terrible moments.
-
- FIORDILIGI, DORABELLA:
- Now that we have heard the news,
- you have the lesser duty:
- Take heart, and plunge your swords
- into both our hearts.
-
- FERRANDO, GUGLIELMO:
- My idol, blame fate
- that I must abandon you.
-
- DORABELLA: Ah no, you shall not leave...
- FIORDILIGI: No, cruel one, you shall not go...
- DORABELLA: First I want to tear out my heart.
- FIORDILIGI: First I want to die at your feet.
- FERRANDO (softly to Don Alfonso): What do you say to that?
- GUGLIELMO (softly to Don Alfonso): You realise?
- DON ALFONSO (softly): Steady, friend, finem lauda.
-
- ALL:
- Thus destiny defrauds
- the hopes of mortals.
- Ah, among so many misfortunes,
- who can ever love life?
-
- -- Lorenzo da Ponte, /Così fan tutte/,
- trans. William Weaver
-
-=head2 v5.20.1-RC1 - Lorenzo da Ponte, Così fan tutte
-
-L<Announced on 2014-08-25 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/08/msg218975.html>
-
- DON ALFONSO:
- I'd like to speak, but I haven't the heart:
- my lip stammers.
- My voice cannot emerge,
- but remains in my throat.
- What will you do? What shall I do?
- Oh what a great catastrophe!
- There can be nothing worse.
- I feel pity for you and for them.
-
- FIORDILIGI: Heavens! For mercy's sake, Signor Alfonso, don't make us
- die.
- DON ALFONSO: My children, you must arm yourselves with constancy.
- DORABELLA: Ye Gods! What evil has occurred? What horrible event? Is my
- love dead, perhaps?
- FIORDILIGI: Is mine dead?
- DON ALFONSO: They are not dead, but they are not far from it.
- DORABELLA: Wounded?
- DON ALFONSO: No.
- FIORDILIGI: Ill?
- DON ALFONSO: Nor that.
- FIORDILIGI: What, then?
- DON ALFONSO: A royal command summons them to the field of battle.
- FIORDILIGI, DORABELLA: Alas, what do I hear? And they will leave?
- DON ALFONSO: Immediately.
- DORABELLA: And there is no way of preventing it?
- DON ALFONSO: There is none.
- FIORDILIGI: And not even a single farewell...
- DON ALFONSO: The unhappy men haven't the courage to see you; but if
- you wish it, they are ready...
- DORABELLA: Where are they?
- DON ALFONSO: Come in, friends.
-
- -- Lorenzo da Ponte, /Così fan tutte/,
- trans. William Weaver
-
-=head2 v5.21.3 - Robert Service, The Men that Don't Fit In
-
-L<Announced on 2014-08-20 by Peter Martini|http://www.nntp.perl.org/group/perl.perl5.porters/2014/08/msg218826.html>
-
- If they just went straight they might go far,
- They are strong and brave and true;
- But they're always tired of the things that are,
- And they want the strange and new.
- They say: "Could I find my proper groove,
- What a deep mark I would make!"
- So they chop and change, and each fresh move
- Is only a fresh mistake.
-
-=head2 v5.21.2 - Neil Armstrong, Buzz Aldrin, Charlie Duke, Final minutes of communication of the first manned moon landing, July 20, 1969.
-
-L<Announced on 2014-07-20 by Abigail|http://www.nntp.perl.org/group/perl.perl5.porters/2014/07/msg217937.html>
-
- Armstrong: Okay. Here's a...Looks like a good area here.
- Aldrin: I got the shadow out there.
- Aldrin: 250, down at 2 1/2, 19 forward.
- Aldrin: Altitude, velocity lights.
- Aldrin: 3 1/2 down, 220 feet, 13 forward.
- Aldrin: 11 forward. Coming down nicely.
- Armstrong: Gonna be right over that crater.
- Aldrin: 200 feet, 4 1/2 down.
- Aldrin: 5 1/2 down.
- Armstrong: I got a good spot [garbled].
- Aldrin: 160 feet, 6 1/2 down.
- Aldrin: 5 1/2 down, 9 forward. You're looking good.
- Aldrin: 120 feet.
- Aldrin: 100 feet, 3 1/2 down, 9 forward. Five percent. Quantity light.
- Aldrin: Okay. 75 feet. And it's looking good. Down a half, 6 forward.
- Duke: 60 seconds.
- Aldrin: Light's on.
- Aldrin: 60 feet, down 2 1/2. 2 forward. 2 forward. That's good.
- Aldrin: 40 feet, down 2 1/2. Picking up some dust.
- Aldrin: 30 feet, 2 1/2 down. [Garbled] shadow.
- Aldrin: 4 forward. 4 forward. Drifting to the right a little. 20 feet,
- down a half.
- Duke: 30 seconds.
- Aldrin: Drifting forward just a little bit; that's good.
- Aldrin: Contact Light.
- Armstrong: Shutdown.
- Aldrin: Okay. Engine Stop.
- Aldrin: ACA out of Detent.
- Armstrong: Out of Detent. Auto.
- Aldrin: Mode Control, both Auto. Descent Engine Command Override, Off.
- Engine Arm, Off. 413 is in.
- Duke: We copy you down, Eagle.
- Armstrong: Engine arm is off.
- Armstrong: Houston, Tranquility Base here. The Eagle has landed.
- Duke: Roger, Twan...[correcting himself] Tranquility. We copy you on
- the ground. You got a bunch of guys about to turn blue.
- We're breathing again. Thanks a lot.
- Aldrin: Thank you.
-
-=head2 v5.21.1 - Robert Jordan, The Crossroads of Twilights, Book 10 of the Wheel of Time
-
-L<Announced on 2014-06-20 by Matthew Horsfall|http://www.nntp.perl.org/group/perl.perl5.porters/2014/06/msg217030.html>
-
- We rode on the winds of the rising storm,
- We ran to the sounds of the thunder.
- We danced among the lightning bolts,
- and tore the world asunder.
-
- -- Anonymous fragment of a poem believed
- written near the end of the previous Age,
- known by some as the Third Age.
- Sometimes attributed to the Dragon
- Reborn.
-
-=head2 v5.21.0 - Friedrich von Schiller, The Song of the Bell
-
-L<Announced on 2014-05-27 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2014/05/msg215826.html>
-
- Walled in fast within the earth
- Stands the form burnt out of clay.
- This must be the bell’s great birth!
- Fellows, lend a hand to-day.
- Sweat must trickle now
- From the burning brow,
- Till the work its master honour.
- Blessing comes from Heaven’s Donor.
-
=head2 v5.20.0 - William Shakespeare, Sonnet 18
L<Announced on 2014-05-27 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2014/05/msg215815.html>
-- William Shakespeare, Sonnet 18
-=head2 v5.20.0-RC1 - Lindsey Buckingham, "Second Hand News"
-
-L<Announced on 2014-05-17 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2014/05/msg215479.html>
-
- When times go bad
- when times go rough
- Won't you lay me down in tall grass
- And let me do my stuff
-
- -- Lindsey Buckingham, "Second Hand News"
-
=head2 v5.19.11 - Lautréamont, Les Chants de Maldoror
L<Announced on 2014-04-20 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/04/msg214580.html>
…that I can't fix…
…with my hands…
-=head2 v5.18.4 - Robert W. Chambers, "The King in Yellow"
-
-L<Announced on 2014-10-01 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2014/10/msg220770.html>
-
- Along the shore the cloud waves break,
- The twin suns sink beneath the lake,
- The shadows lengthen
- In Carcosa.
-
- Strange is the night where black stars rise,
- And strange moons circle through the skies
- But stranger still is
- Lost Carcosa.
-
- Songs that the Hyades shall sing,
- Where flap the tatters of the King,
- Must die unheard in
- Dim Carcosa.
-
- Song of my soul, my voice is dead;
- Die thou, unsung, as tears unshed
- Shall dry and die in
- Lost Carcosa.
-
- -- Cassilda's Song in "The King in Yellow," Act i, Scene 2.
- Robert W. Chambers
-
-=head2 v5.18.3 - (no epigraph)
-
-(no epigraph)
-
-=head2 v5.18.3-RC2 - Robert W. Chambers, "The King in Yellow"
-
-L<Announced on 2014-09-27|http://nntp.perl.org/group/perl.perl5.porters/220613>
-
-"Ah! I see it now!" I shrieked. "You have seized the throne and the
-empire. Woe! woe to you who are crowned with the crown of the King in
-Yellow!"
-
- -- Robert W. Chambers, The King in Yellow, Act I, Scene 2.
-
-=head2 v5.18.3-RC1 - Robert W. Chambers, "The King in Yellow"
-
-L<Announced on 2014-09-17|http://nntp.perl.org/group/perl.perl5.porters/220072>
-
- CAMILLA: You, sir, should unmask.
-
- STRANGER: Indeed?
-
- CASSILDA: Indeed it's time. We all have laid aside disguise but you.
-
- STRANGER: I wear no mask.
-
- CAMILLA: (Terrified, aside to Cassilda.) No mask? No mask!
-
- -- Robert W. Chambers, The King in Yellow, Act I, Scene 2.
-
=head2 v5.18.2 - Miss Manners
L<Announced on 2014-01-06 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2014/01/msg211224.html>
XXX Generate this with:
- perl Porting/acknowledgements.pl v5.20.3..HEAD
+ perl Porting/acknowledgements.pl v5.21.0..HEAD
=head1 Reporting Bugs
[ACKNOWLEDGEMENTS SECTION FROM PERLDELTA]
We expect to release version [NEXT BLEAD VERSION.SUBVERSION] on [FUTURE
-DATE]. The next major stable release of Perl 5, version 22.0, should
-appear in May 2015.
+DATE]. The next major stable release of Perl 5, version 20.0, should
+appear in May 2014.
[YOUR SALUTATION HERE]
This script is run as:
- perl Porting/make-rmg-checklist \
- --type [BLEAD-POINT or MAINT or ...] > /tmp/rmg.pod
+ perl Porting/make-rmg-checklist \
+ --type [BLEAD-POINT or MAINT or ...] > /tmp/rmg.pod
You can also pass the C<--html> flag to generate an HTML document instead of
POD.
- perl Porting/make-rmg-checklist --html \
- --type [BLEAD-POINT or MAINT or ...] > /tmp/rmg.html
+ perl Porting/make-rmg-checklist --html \
+ --type [BLEAD-POINT or MAINT or ...] > /tmp/rmg.html
=head1 SYNOPSIS
a few weeks before the release, a number of steps are performed,
including bumping the version to 5.10.2
- ...a few weeks pass...
+ ...a few weeks passes...
perl-5.10.2-RC1 is released
sweet-talking somebody with a Github account into obedience is needed. This
is only needed on the day of the release or shortly afterwards.
+=for checklist skip RC
+
=head3 Quotation for release announcement epigraph
-You will need a quotation to use as an epigraph to your release announcement.
+I<SKIP this step for RC>
+
+For all except an RC release of perl, you will need a quotation
+to use as an epigraph to your release announcement.
=head2 Building a release - advance actions
Ensure dual-life CPAN modules are stable, which comes down to:
- for each module that fails its regression tests on $current
- did it fail identically on $previous?
- if yes, "SEP" (Somebody Else's Problem)
- else work out why it failed (a bisect is useful for this)
+ for each module that fails its regression tests on $current
+ did it fail identically on $previous?
+ if yes, "SEP" (Somebody Else's Problem)
+ else work out why it failed (a bisect is useful for this)
- attempt to group failure causes
+ attempt to group failure causes
- for each failure cause
- is that a regression?
- if yes, figure out how to fix it
- (more code? revert the code that broke it)
- else
- (presumably) it's relying on something un-or-under-documented
- should the existing behaviour stay?
- yes - goto "regression"
- no - note it in perldelta as a significant bugfix
- (also, try to inform the module's author)
+ for each failure cause
+ is that a regression?
+ if yes, figure out how to fix it
+ (more code? revert the code that broke it)
+ else
+ (presumably) it's relying on something un-or-under-documented
+ should the existing behaviour stay?
+ yes - goto "regression"
+ no - note it in perldelta as a significant bugfix
+ (also, try to inform the module's author)
=head3 monitor smoke tests for failures
Similarly, monitor the smoking of perl for compiler warnings, and try to
fix.
-=for checklist skip BLEAD-POINT
-
-=head3 monitor CPAN testers for failures
-
-For any release except a BLEAD-POINT: Examine the relevant analysis report(s)
-at http://analysis.cpantesters.org/beforemaintrelease to see how the impending
-release is performing compared to previous releases with regard to building
-and testing CPAN modules.
-
=head3 update perldelta
Get perldelta in a mostly finished state.
There is a tool to semi-automate this process:
- $ ./perl -Ilib Porting/bump-perl-version -i 5.10.0 5.10.1
+ $ ./perl -Ilib Porting/bump-perl-version -i 5.10.0 5.10.1
Remember that this tool is largely just grepping for '5.10.0' or whatever,
so it will generate false positives. Be careful not change text like
Be particularly careful with F<INSTALL>, which contains a mixture of
C<5.10.0>-type strings, some of which need bumping on every release, and
some of which need to be left unchanged.
-See below in L<"update INSTALL"> for more details.
-
-For the first RC release leading up to a BLEAD-FINAL release, update the
-description of which releases are now "officially" supported in
-F<pod/perlpolicy.pod>.
+The line in F<INSTALL> about "is binary incompatible with" requires a
+correct choice of earlier version to declare incompatibility with.
When doing a BLEAD-POINT or BLEAD-FINAL release, also make sure the
C<PERL_API_*> constants in F<patchlevel.h> are in sync with the version
After editing, regenerate uconfig.h (this must be run on a system with a
/bin/sh available):
- $ perl regen/uconfig_h.pl
+ $ perl regen/uconfig_h.pl
This might not cause any new changes.
-You may have to add stub entries in C<%Module::CoreList::version>,
-C<%Module::CoreList::deprecated> and C<%Module::CoreList::Utils::delta>.
-If so, you must up their version numbers as well.
-
Test your changes:
- $ git clean -xdf # careful if you don't have local files to keep!
- $ ./Configure -des -Dusedevel
- $ make
- $ make test
+ $ git clean -xdf # careful if you don't have local files to keep!
+ $ ./Configure -des -Dusedevel
+ $ make
+ $ make test
Commit your changes:
- $ git status
- $ git diff
- B<review the delta carefully>
+ $ git status
+ $ git diff
+ B<review the delta carefully>
- $ git commit -a -m 'Bump the perl version in various places for 5.x.y'
+ $ git commit -a -m 'Bump the perl version in various places for 5.x.y'
At this point you may want to compare the commit with a previous bump to
see if they look similar. See commit f7cf42bb69 for an example of a
=head3 update INSTALL
-Review and update INSTALL to account for the change in version number.
-The lines in F<INSTALL> about "is not binary compatible with" may require a
-correct choice of earlier version to declare incompatibility with. These are
-in the "Changes and Incompatibilities" and "Coexistence with earlier versions
-of perl 5" sections.
+Review and update INSTALL to account for the change in version number;
+in particular, the "Coexistence with earlier versions of perl 5" section.
Be particularly careful with the section "Upgrading from 5.X.Y or earlier".
The "X.Y" needs to be changed to the most recent version that we are
Check that the copyright years are up to date by running:
- $ ./perl t/porting/copyright.t --now
+ $ ./perl t/porting/copyright.t --now
Remedy any test failures by editing README or perl.c accordingly (search for
the "Copyright"). If updating perl.c, check if the file's own copyright date in
BLEAD-FINAL, MAINT, and RC releases, since blead will already be frozen in
those cases. Create the branch by running
- git checkout -b release-5.xx.yy
+ git checkout -b release-5.xx.yy
=head3 build a clean perl
$ ./Configure -Dusedevel -des && make
-=head3 Check module versions
-
-For each Perl release since the previous release of the current branch, check
-for modules that have identical version numbers but different contents by
-running:
-
- $ ./perl -Ilib Porting/cmpVERSION.pl --tag=v5.X.YY
-
-(This is done automatically by F<t/porting/cmp_version.t> for the previous
-release of the current branch, but not for any releases from other branches.)
-
-Any modules that fail will need a version bump, plus a nudge to the upstream
-maintainer for 'cpan' upstream modules.
-
=head3 update Module::CoreList
=head4 Bump Module::CoreList* $VERSIONs
-If necessary, bump C<$Module::CoreList::VERSION> (there's no need to do this
-for every RC; in RC1, bump the version to a new clean number that will
+If necessary, bump C<$Module::CoreList::VERSION> (there's no need to do this for
+every RC; in RC1, bump the version to a new clean number that will
appear in the final release, and leave as-is for the later RCs and final).
It may also happen that C<Module::CoreList> has been modified in blead, and
hence has a new version number already. (But make sure it is not the same
C<$Module::CoreList::VERSION>. If necessary, bump those two versions to match
before proceeding.
-The files to modify are: F<dist/Module-CoreList/lib/Module/CoreList.pm>,
-F<dist/Module-CoreList/lib/Module/CoreList/Utils.pm> and
-F<dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm>.
-
=head4 Update C<Module::CoreList> with module version data for the new release.
Note that if this is a MAINT release, you should run the following actions
badly-indexed CPAN modules unrelated to the modules actually in core.
Assuming all goes well, it will update
F<dist/Module-CoreList/lib/Module/CoreList.pm> and possibly
+F<dist/Module-CoreList/lib/Module/CoreList.pod> and/or
F<dist/Module-CoreList/lib/Module/CoreList/Utils.pm>.
Check those files over carefully:
$ git diff dist/Module-CoreList/lib/Module/CoreList.pm
+ $ git diff dist/Module-CoreList/lib/Module/CoreList.pod
$ git diff dist/Module-CoreList/lib/Module/CoreList/Utils.pm
=head4 Bump version in Module::CoreList F<Changes>
=head4 Add Module::CoreList version bump to perldelta
-Add a perldelta entry for the new Module::CoreList version. You only
-need to do this if you want to add notes about the changes included
-with this version of Module::CoreList. Otherwise, its version bump
-will be automatically filled in below in L<finalize perldelta>.
+Add a perldelta entry for the new Module::CoreList version.
=for checklist skip RC
-=head4 Update C<%Module::CoreList::released>
+=head4 Update C<%Module::CoreList::released> and C<CAVEATS>
+
+In addition, if this is a final release (rather than a release candidate):
+
+=over 4
+
+=item *
-For any release except an RC: Update this version's entry in the C<%released>
-hash with today's date.
+Update this version's entry in the C<%released> hash with today's date.
+
+=item *
+
+Make sure that the script has correctly updated the C<CAVEATS> section
+(Note, the C<CAVEATS> section is in
+F<dist/Module-CoreList/lib/Module/CoreList.pod>)
+
+=back
=head4 Commit Module::CoreList changes
(unless this is for MAINT; in which case commit it to blead first, then
cherry-pick it back).
- $ git commit -m 'Update Module::CoreList for 5.x.y' \
- dist/Module-CoreList/Changes \
- dist/Module-CoreList/lib/Module/CoreList.pm \
- dist/Module-CoreList/lib/Module/CoreList/Utils.pm
+ $ git commit -m 'Update Module::CoreList for 5.x.y' dist/Module-CoreList/Changes dist/Module-CoreList/lib/Module/CoreList.pm dist/Module-CoreList/lib/Module/CoreList.pod dist/Module-CoreList/lib/Module/CoreList/Utils.pm
=head4 Rebuild and test
-Build and test to get the changes into the currently built lib directory and to
-ensure all tests are passing.
+Build and test to get the changes into the currently built lib directory and to ensure
+all tests are passing.
=head3 finalize perldelta
Finalize the perldelta. In particular, fill in the Acknowledgements
section, which can be generated with something like:
- $ perl Porting/acknowledgements.pl v5.15.0..HEAD
-
-Fill in the "New/Updated Modules" sections now that Module::CoreList is
-updated:
+ $ perl Porting/acknowledgements.pl v5.15.0..HEAD
- $ ./perl -Ilib Porting/corelist-perldelta.pl \
- --mode=update pod/perldelta.pod
+Fill in the "New/Updated Modules" sections now that Module::CoreList is updated:
-For a MAINT release use something like this instead:
-
- $ ./perl -Ilib Porting/corelist-perldelta.pl 5.020001 5.020002 \
- --mode=update pod/perldelta.pod
+ $ ./perl -Ilib Porting/corelist-perldelta.pl --mode=update pod/perldelta.pod
Ideally, also fill in a summary of the major changes to each module for which
an entry has been added by F<corelist-perldelta.pl>.
Also, you may want to generate and view an HTML version of it to check
formatting, e.g.
- $ ./perl -Ilib ext/Pod-Html/bin/pod2html pod/perldelta.pod > \
- /tmp/perldelta.html
+ $ ./perl -Ilib ext/Pod-Html/bin/pod2html pod/perldelta.pod > /tmp/perldelta.html
Another good HTML preview option is http://search.cpan.org/pod2html
$ cp ..../blead/pod/perlhist.pod pod/
$ git commit -m 'sync perlhist from blead' pod/perlhist.pod
+=for checklist skip RC
+
=head3 update perlhist.pod
+I<You MUST SKIP this step for a RC release>
+
Add an entry to F<pod/perlhist.pod> with the release date, e.g.:
David 5.10.1 2009-Aug-06
-List yourself in the left-hand column, and if this is the first release
-that you've ever done, make sure that your name is listed in the section
-entitled C<THE KEEPERS OF THE PUMPKIN>.
+Make sure that the correct pumpking is listed in the left-hand column, and
+if this is the first release under the stewardship of a new pumpking, make
+sure that his or her name is listed in the section entitled
+C<THE KEEPERS OF THE PUMPKIN>.
I<If you're making a BLEAD-FINAL release>, also update the "SELECTED
RELEASE SIZES" section with the output of
static const char * const local_patches[] = {
NULL
+ ,"RC1"
- #ifdef PERL_GIT_UNCOMMITTED_CHANGES
- ,"uncommitted-changes"
- #endif
+ PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */
Be sure to commit your change:
commits. (Note that for an odd-numbered version, perl will install
itself as C<perl5.x.y>). C<perl -v> will identify itself as:
- This is perl 5, version X, subversion Y (v5.X.Y (v5.X.Z-NNN-gdeadbeef))
+ This is perl 5, version X, subversion Y (v5.X.Y (v5.X.Z-NNN-gdeadbeef))
where 5.X.Z is the latest tag, NNN the number of commits since this tag,
and C<< deadbeef >> commit of that tag.
Create a tarball. Use the C<-s> option to specify a suitable suffix for
the tarball and directory name:
- $ cd root/of/perl/tree
- $ make distclean # make sure distclean works
- $ git clean -xdf # make sure perl and git agree on files
- # git clean should not output anything!
- $ git status # and there's nothing lying around
+ $ cd root/of/perl/tree
+ $ make distclean
+ $ git clean -xdf # make sure perl and git agree on files
+ $ git status # and there's nothing lying around
- $ perl Porting/makerel -b -s RC1 # for a release candidate
- $ perl Porting/makerel -b # for the release itself
+ $ perl Porting/makerel -b -s RC1 # for a release candidate
+ $ perl Porting/makerel -b # for a final release
This creates the directory F<../perl-x.y.z-RC1> or similar, copies all
the MANIFEST files into it, sets the correct permissions on them, then
$ ./Configure -des && make all test
- # Or for a development release:
- $ ./Configure -Dusedevel -des && make all test
-
=head4 Run the test harness and install
Check that the test harness and install work on each test machine:
$ bin/cpan
- # Or, perhaps:
- $ bin/cpan5.xx.x
-
=head4 Install the Inline module with CPAN and test it
Try installing a popular CPAN module that's reasonably complex and that
has dependencies; for example:
- CPAN> install Inline::C
+ CPAN> install Inline
CPAN> quit
Check that your perl can run this:
static const char * const local_patches[] = {
NULL
- ,"RC1"
- #ifdef PERL_GIT_UNCOMMITTED_CHANGES
- ,"uncommitted-changes"
- #endif
+ PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */
Be sure to commit your change:
Merge the (local) release branch back into master now, and delete it.
- git checkout blead
- git pull
- git merge release-5.xx.yy
- git push
- git branch -d release-5.xx.yy
+ git checkout blead
+ git pull
+ git merge release-5.xx.yy
+ git push
+ git branch -d release-5.xx.yy
Note: The merge will create a merge commit if other changes have been pushed
to blead while you've been working on your release branch. Do NOT rebase your
=for checklist skip RC
-=head3 Release schedule
-
-I<You MUST SKIP this step for RC>
-
-Tick the entry for your release in F<Porting/release_schedule.pod>.
-
-=for checklist skip RC
-
=head3 Module::CoreList nagging
I<You MUST SKIP this step for RC>
After bumping the version, follow the section L<"update INSTALL"> to
ensure all version number references are correct.
-(Note: The version is NOT bumped immediately after a MAINT release in order
-to avoid confusion and wasted time arising from bug reports relating to
-"intermediate versions" such as 5.20.1-and-a-bit: If the report is caused
-by a bug that gets fixed in 5.20.2 and this intermediate version already
-calls itself 5.20.2 then much time can be wasted in figuring out why there
-is a failure from something that "should have been fixed". If the bump is
-late then there is a much smaller window of time for such confusing bug
-reports to arise. (The opposite problem -- trying to figure out why there
-*is* a bug in something calling itself 5.20.1 when in fact the bug was
-introduced later -- shouldn't arise for MAINT releases since they should,
-in theory, only contain bug fixes but never regressions.))
-
=head3 clean build and test
Run a clean build and test to make sure nothing obvious is broken.
In particular, F<Porting/perldelta_template.pod> is intentionally exempted
from podchecker tests, to avoid false positives about placeholder text.
However, once it's copied to F<pod/perldelta.pod> the contents can now
-cause test failures. Problems should be resolved by doing one of the
+cause test failures. Problems should resolved by doing one of the
following:
=over
Copy the perldelta.pod for this release into blead; for example:
- $ cd ..../blead
- $ cp -i ../5.10.x/pod/perldelta.pod pod/perl5101delta.pod # for example
- $ git add pod/perl5101delta.pod
+ $ cd ..../blead
+ $ cp -i ../5.10.x/pod/perldelta.pod pod/perl5101delta.pod # for example
+ $ git add pod/perl5101delta.pod
Don't forget to set the NAME correctly in the new file (e.g. perl5101delta
rather than perldelta).
Make sure any recent F<pod/perlhist.pod> entries are copied to
F<perlhist.pod> on blead. e.g.
- 5.8.9 2008-Dec-14
+ 5.8.9 2008-Dec-14
=head3 bump RT version number
=head2 Building a release - the day after
+=head3 link announcement in epigraphs.pod
+
+Add, to your quote to F<Porting/epigraphs.pod>, a link to the release
+announcement in the web-visible mailing list archive. Commit it.
+
=for checklist skip BLEAD-FINAL, MAINT, RC
=head3 update Module::CoreList
$ ./perl -Ilib Porting/corelist.pl cpan
-This will update F<dist/Module-CoreList/lib/Module/CoreList.pm> and
+This will update F<dist/Module-CoreList/lib/Module/CoreList.pm>,
+F<dist/Module-CoreList/lib/Module/CoreList.pod> and
F<dist/Module-CoreList/lib/Module/CoreList/Utils.pm> as it did before,
but this time adding new sections for the next BLEAD-POINT release.
Run
- $ ./perl -Ilib -MModule::CoreList \
- -le 'print Module::CoreList->find_version($]) ? "ok" : "not ok"'
+ $ ./perl -Ilib -MModule::CoreList -le 'print Module::CoreList->find_version($]) ? "ok" : "not ok"'
and check that it outputs "ok" to prove that Module::CoreList now knows
about blead's current version.
This schedule lists the projected or historical development and
release schedules for the next, current and previous stable versions
-of Perl. Dates with two or more question marks will only be releases if
+of Perl. Dates with all question marks will only be releases if
deemed necessary by the Pumpking.
-=head2 Perl 5.22
-
-Code freezes (which happen in the 5.21.X series)
-
- 2015-01-20 5.21.8 Contentious changes freeze
- 2015-02-20 5.21.9 User-visible changes freeze
- 2015-03-20 5.21.10 Full code freeze
- 2015-05-20 5.22.0 Stable release!
-
=head2 Perl 5.20
- 2014-05-27 5.20.0 ✓ Ricardo Signes
- 2014-09-14 5.20.1 ✓ Steve Hay
- 2015-01-?? 5.20.2 Steve Hay
+Code freezes (which happen in the 5.19.X series)
+
+ 2014-01-20 5.19.8 Contentious changes freeze
+ 2014-02-20 5.19.9 User-visible changes freeze
+ 2014-03-20 5.19.10 Full code freeze
+ 2014-05-20 5.20.0 Stable release!
=head2 Perl 5.18
+Release schedule (with release manager):
+
2013-05-18 5.18.0 ✓ Ricardo Signes
2013-08-12 5.18.1 ✓ Ricardo Signes
- 2014-01-06 5.18.2 ✓ Ricardo Signes
- 2014-10-01 5.18.3 ✓ Ricardo Signes
- 2014-10-01 5.18.4 ✓ Ricardo Signes
- 2015-??-?? 5.18.5 ??
+ 2013-11-?? 5.18.2 Ricardo Signes
+
+(RC0 will be released once we think that all the blockers have been
+addressed. This typically means some time in April or May.)
+
+=head2 Perl 5.16
+
+Release schedule (with release managers):
+
+ 2012-05-20 5.16.0 ✓ Ricardo Signes
+ 2012-08-08 5.16.1 ✓ Ricardo Signes
+ 2012-11-01 5.16.2 ✓ Ricardo Signes
+ 2013-03-11 5.16.3 ✓ Ricardo Signes
+ ????-??-?? 5.16.4 ??
=head1 DEVELOPMENT RELEASE SCHEDULE
the next four releases. If a stable version of Perl is released,
you should reset the version numbers to the next blead series.
+=head2 Perl 5.19
+
+ 2013-05-20 5.19.0 Ricardo Signes
+ 2013-06-20 5.19.1 David Golden
+ 2013-07-20 5.19.2 Aristotle Pagaltzis
+ 2013-08-20 5.19.3 Steve Hay
+ 2013-09-20 5.19.4 Steve Hay
+ 2013-10-20 5.19.5 Steve Hay
+ 2013-11-20 5.19.6 Chris Williams
+ 2013-12-20 5.19.7 Abigail
+ 2014-01-20 5.19.8 Ricardo Signes
+ 2014-02-20 5.19.9 Tony Cook
+ 2014-03-20 5.19.10 Aaron Crane
+ 2014-04-20 5.19.11 Steve Hay
+
=head2 Perl 5.21
- 2014-05-20 5.21.0 ✓ Ricardo Signes
- 2014-06-20 5.21.1 ✓ Matthew Horsfall
- 2014-07-20 5.21.2 ✓ Abigail
- 2014-08-20 5.21.3 ✓ Peter Martini
- 2014-09-20 5.21.4 ✓ Steve Hay
- 2014-10-20 5.21.5 ✓ Abigail
- 2014-11-20 5.21.6 ✓ Chris "BinGOs" Williams
- 2014-12-20 5.21.7 ✓ Max Maischein
- 2015-01-20 5.21.8 ✓ Matthew Horsfall
+ 2014-05-20 5.21.0 Ricardo Signes
+ 2014-06-20 5.21.1 Matthew Horsfall
+ 2014-07-20 5.21.2 Abigail
+ 2014-08-20 5.21.3 ?
+ 2014-09-20 5.21.4 ?
+ 2014-10-20 5.21.5 ?
+ 2014-11-20 5.21.6 ?
+ 2014-12-20 5.21.7 ?
+ 2015-01-20 5.21.8 ?
2015-02-20 5.21.9 ?
2015-03-20 5.21.10 ?
2015-04-20 5.21.11 ?
-(RC0 for 5.22.0 will be released once we think that all the blockers have been
-addressed. This typically means some time in April or May.)
-
=head1 VICTIMS
The following porters have all consented to do at least
Jesse Vincent <jesse@cpan.org>
Leon Brocard <acme@astray.com>
Matt Trout <mst@shadowcat.co.uk>
-Matthew Horsfall <wolfsage@gmail.com>
Max Maischein <corion@cpan.org>
-Peter Martini <petercmartini@gmail.com>
Philippe Bruhat <book@cpan.org>
Ricardo Signes <rjbs@cpan.org>
Stevan Little <stevan.little@iinteractive.com>
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.20.3.
+options would be nice for perl 5.21.0.
=head2 Profile Perl - am I hot or not?
=head2 Virtualize operating system access
Implement a set of "vtables" that virtualizes operating system access
-(chdir(), chmod(), dbmopen(), getenv(), glob(), link(), mkdir(), open(),
-opendir(), readdir(), rename(), rmdir(), stat(), sysopen(), uname(),
-unlink(), etc.) At the very least these interfaces should take SVs as
-"name" arguments instead of bare char pointers; probably the most
-flexible and extensible way would be for the Perl-facing interfaces to
-accept HVs. The system needs to be per-operating-system and
-per-file-system hookable/filterable, preferably both from XS and Perl
-level (L<perlport/"Files and Filesystems"> is good reading at this
-point, in fact, all of L<perlport> is.)
+(open(), mkdir(), unlink(), readdir(), getenv(), etc.) At the very
+least these interfaces should take SVs as "name" arguments instead of
+bare char pointers; probably the most flexible and extensible way
+would be for the Perl-facing interfaces to accept HVs. The system
+needs to be per-operating-system and per-file-system
+hookable/filterable, preferably both from XS and Perl level
+(L<perlport/"Files and Filesystems"> is good reading at this point,
+in fact, all of L<perlport> is.)
This has actually already been implemented (but only for Win32),
take a look at F<iperlsys.h> and F<win32/perlhost.h>. While all Win32
=head1 Big projects
Tasks that will get your name mentioned in the description of the "Highlights
-of 5.20.3"
+of 5.21.0"
=head2 make ithreads more robust
Perl is Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
-2013, 2014, 2015 by Larry Wall and others. All rights reserved.
+2013, 2014 by Larry Wall and others. All rights reserved.
underlying windows pid. Most posix compliant Proc functions expect
the cygwin pid, but several Win32::Process functions expect the
winpid. E.g. C<$$> is the cygwin pid of F</usr/bin/perl>, which is not
-the winpid. Use C<Cygwin::pid_to_winpid()> and C<Cygwin::winpid_to_pid()>
+the winpid. Use C<Cygwin::winpid_to_pid()> and C<Cygwin::winpid_to_pid()>
to translate between them.
=item * Cygwin vs. Windows errors
Make perl executable and create a symlink for libperl:
chmod a+x /boot/common/bin/perl
- cd /boot/common/lib; ln -s perl5/5.20.3/BePC-haiku/CORE/libperl.so .
+ cd /boot/common/lib; ln -s perl5/5.21.0/BePC-haiku/CORE/libperl.so .
-Replace C<5.20.3> with your respective version of Perl.
+Replace C<5.21.0> 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.20.3.tar.gz
- tar -xzf perl-5.20.3.tar.gz
- cd perl-5.20.3
+ curl -O http://www.cpan.org/src/perl-5.21.0.tar.gz
+ tar -xzf perl-5.21.0.tar.gz
+ cd perl-5.21.0
./Configure -des -Dprefix=/usr/local/
make
make test
=head1 DESCRIPTION
-The latest Perl release (5.20.3 as of this writing) builds without changes
+The latest Perl release (5.21.0 as of this writing) builds without changes
under all versions of Mac OS X from 10.3 "Panther" onwards.
In order to build your own version of Perl you will need 'make',
=item Additional Perl modules
- unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.20.3/
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.21.0/
Same remark as above applies. Additionally, if this directory is not
one of directories on @INC (and @INC is influenced by C<PERLLIB_PREFIX>), you
choice. Once you have done so, use a command like the following to
unpack the archive:
- vmstar -xvf perl-5^.20^.3.tar
+ vmstar -xvf perl-5^.21^.0.tar
Then set default to the top-level source directory like so:
- set default [.perl-5^.20^.3]
+ set default [.perl-5^.21^.0]
and proceed with configuration as described in the next section.
=item Microsoft Visual C++
-The nmake that comes with Visual C++ will suffice for building. Visual C
-requires that certain things be set up in the console before Visual C will
-sucessfully run. To make a console box be able to run the C compiler, you will
-need to beforehand, run the C<vcvars32.bat> file to compile for x86-32 and for
-x86-64 C<vcvarsall.bat x64> or C<vcvarsamd64.bat>. On a typical install of a
-Microsoft C compiler product, these batch files will already be in your C<PATH>
-environment variable so you may just type them without an absolute path into
-your console. If you need to find the absolute path to the batch file, it is
-usually found somewhere like C:\Program Files\Microsoft Visual Studio\VC98\Bin.
-With some newer Micrsoft C products (released after ~2004), the installer will
-put a shortcut in the start menu to launch a new console window with the
-console already set up for your target architecture (x86-32 or x86-64 or IA64).
-With the newer compilers, you may also use the older batch files if you choose
-so.
+The nmake that comes with Visual C++ will suffice for building.
+You will need to run the VCVARS32.BAT file, usually found somewhere
+like C:\Program Files\Microsoft Visual Studio\VC98\Bin.
+This will set your build environment.
You can also use dmake to build using Visual C++; provided, however,
you set OSRELEASE to "microsft" (or whatever the directory name
Type "dmake" (or "nmake" if you are using that make).
This should build everything. Specifically, it will create perl.exe,
-perl520.dll at the perl toplevel, and various other extension dll's
+perl521.dll at the perl toplevel, and various other extension dll's
under the lib\auto directory. If the build fails for any reason, make
sure you have done the previous steps correctly.
-If you are advanced enough with building C code, here is a suggestion to speed
-up building perl, and the later C<make test>. Try to keep your PATH enviromental
-variable with the least number of folders possible (remember to keep your C
-compiler's folders there). C<C:\WINDOWS\system32> or C<C:\WINNT\system32>
-depending on your OS version should be first folder in PATH, since "cmd.exe"
-is the most commonly launched program during the build and later testing.
-
=back
=head2 Testing Perl on Windows
Note that not all of the extensions available from CPAN may work
in the Windows environment; you should check the information at
-L<http://www.cpantesters.org/> before investing too much effort into
+L<http://testers.cpan.org/> before investing too much effort into
porting modules that don't readily build.
Most extensions (whether they require a C compiler or not) can
If a module implements XSUBs, you will need one of the supported
C compilers. You must make sure you have set up the environment for
-the compiler for command-line compilation before running C<perl Makefile.PL>
-or any invocation of make.
+the compiler for command-line compilation.
If a module does not build for some reason, look carefully for
why it failed, and report problems to the module author. If
but that may be just luck. Other AntiVirus software may have similar issues.
-A git GUI shell extension for Windows such as TortoiseGit will cause the build
-and later C<make test> to run much slower since every file is checked for its
-git status as soon as it is created and/or modified. TortoiseGit doesn't cause
-any test failures or build problems unlike the antivirus software described
-above, but it does cause similar slowness. It is suggested to use Task Manager
-to look for background processes which use high CPU amounts during the building
-process.
-
Some of the built-in functions do not act exactly as documented in
L<perlfunc>, and a few are not implemented at all. To avoid
surprises, particularly if you have had prior exposure to Perl
Support for 64-bit Windows added in 5.8 (ActiveState Corp).
-Last updated: 07 October 2014
+Last updated: 22 October 2013
=cut
(A slightly shorter form is C<av_tindex>.)
-=for apidoc av_tindex
-
-Same as L</av_top_index>.
-
=for apidoc av_len
-Same as L</av_top_index>. Note that, unlike what the name implies, it returns
-the highest index in the array, so to get the size of the array you need to use
-S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
-expect.
+Same as L</av_top_index>. Returns the highest index in the array. Note that the
+return value is +1 what its name implies it returns; and hence differs in
+meaning from what the similarly named L</sv_len> returns.
=cut
*/
Set the highest index in the array to the given number, equivalent to
Perl's C<$#array = $fill;>.
-The number of elements in the array will be C<fill + 1> after
+The number of elements in the an array will be C<fill + 1> after
av_fill() returns. If the array was previously shorter, then the
additional elements appended are set to NULL. If the array
was longer, then the excess elements are freed. C<av_fill(av, -1)> is
* /bin/pdksh, /bin/ash, /bin/bash, or even something such as
* D:/bin/sh.exe.
*/
-#define SH_PATH "$targetsh" /**/
+#define SH_PATH "$sh" /**/
/* SIG_NAME:
* This symbol contains a list of signal names in order of
cx->blk_format.gv = gv; \
cx->blk_format.retop = (retop); \
cx->blk_format.dfoutgv = PL_defoutgv; \
- cx->blk_u16 = 0; \
if (!CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv); \
CvDEPTH(cv)++; \
SvREFCNT_inc_void(cx->blk_format.dfoutgv)
#define POPSUB(cx,sv) \
STMT_START { \
const I32 olddepth = cx->blk_sub.olddepth; \
- if (!(cx->blk_u16 & CxPOPSUB_DONE)) { \
- cx->blk_u16 |= CxPOPSUB_DONE; \
RETURN_PROBE(CvNAMED(cx->blk_sub.cv) \
? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) \
: GvENAME(CvGV(cx->blk_sub.cv)), \
CLEAR_ARGARRAY(cx->blk_sub.argarray); \
} \
} \
- } \
sv = MUTABLE_SV(cx->blk_sub.cv); \
LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]); \
if (sv && (CvDEPTH((const CV*)sv) = olddepth)) \
#define POPFORMAT(cx) \
STMT_START { \
- if (!(cx->blk_u16 & CxPOPSUB_DONE)) { \
CV * const cv = cx->blk_format.cv; \
GV * const dfuot = cx->blk_format.dfoutgv; \
- cx->blk_u16 |= CxPOPSUB_DONE; \
setdefout(dfuot); \
LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]); \
if (!--CvDEPTH(cv)) \
SvREFCNT_dec_NN(cx->blk_format.cv); \
SvREFCNT_dec_NN(dfuot); \
- } \
} STMT_END
/* eval context */
#define CxLABEL_len(c,len) (0 + CopLABEL_len((c)->blk_oldcop, len))
#define CxLABEL_len_flags(c,len,flags) (0 + CopLABEL_len_flags((c)->blk_oldcop, len, flags))
#define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
-#define CxLVAL(c) (0 + ((c)->blk_u16 & 0xff))
-/* POPSUB has already been performed on this context frame */
-#define CxPOPSUB_DONE 0x100
-
+#define CxLVAL(c) (0 + (c)->blk_u16)
#define PUSHLOOP_PLAIN(cx, s) \
cx->blk_loop.resetsp = s - PL_stack_base; \
+++ /dev/null
-package CGI;
-require 5.008001;
-use if $] >= 5.019, 'deprecate';
-use Carp 'croak';
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-# The most recent version and complete docs are available at:
-# http://search.cpan.org/dist/CGI.pm
-
-# The revision is no longer being updated since moving to git.
-$CGI::revision = '$Id: CGI.pm,v 1.266 2009/07/30 16:32:34 lstein Exp $';
-$CGI::VERSION='3.65';
-
-# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
-# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
-# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
-use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
-
-#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
-# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
-
-use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
- 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
-
-{
- local $^W = 0;
- $TAINTED = substr("$0$^X",0,0);
-}
-
-$MOD_PERL = 0; # no mod_perl by default
-
-#global settings
-$POST_MAX = -1; # no limit to uploaded files
-$DISABLE_UPLOADS = 0;
-
-@SAVED_SYMBOLS = ();
-
-
-# >>>>> Here are some globals that you might want to adjust <<<<<<
-sub initialize_globals {
- # Set this to 1 to enable copious autoloader debugging messages
- $AUTOLOAD_DEBUG = 0;
-
- # Set this to 1 to generate XTML-compatible output
- $XHTML = 1;
-
- # Change this to the preferred DTD to print in start_html()
- # or use default_dtd('text of DTD to use');
- $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
- 'http://www.w3.org/TR/html4/loose.dtd' ] ;
-
- # Set this to 1 to enable NOSTICKY scripts
- # or:
- # 1) use CGI '-nosticky';
- # 2) $CGI::NOSTICKY = 1;
- $NOSTICKY = 0;
-
- # Set this to 1 to enable NPH scripts
- # or:
- # 1) use CGI qw(-nph)
- # 2) CGI::nph(1)
- # 3) print header(-nph=>1)
- $NPH = 0;
-
- # Set this to 1 to enable debugging from @ARGV
- # Set to 2 to enable debugging from STDIN
- $DEBUG = 1;
-
- # Set this to 1 to make the temporary files created
- # during file uploads safe from prying eyes
- # or do...
- # 1) use CGI qw(:private_tempfiles)
- # 2) CGI::private_tempfiles(1);
- $PRIVATE_TEMPFILES = 0;
-
- # Set this to 1 to generate automatic tab indexes
- $TABINDEX = 0;
-
- # Set this to 1 to cause files uploaded in multipart documents
- # to be closed, instead of caching the file handle
- # or:
- # 1) use CGI qw(:close_upload_files)
- # 2) $CGI::close_upload_files(1);
- # Uploads with many files run out of file handles.
- # Also, for performance, since the file is already on disk,
- # it can just be renamed, instead of read and written.
- $CLOSE_UPLOAD_FILES = 0;
-
- # Automatically determined -- don't change
- $EBCDIC = 0;
-
- # Change this to 1 to suppress redundant HTTP headers
- $HEADERS_ONCE = 0;
-
- # separate the name=value pairs by semicolons rather than ampersands
- $USE_PARAM_SEMICOLONS = 1;
-
- # Do not include undefined params parsed from query string
- # use CGI qw(-no_undef_params);
- $NO_UNDEF_PARAMS = 0;
-
- # return everything as utf-8
- $PARAM_UTF8 = 0;
-
- # Other globals that you shouldn't worry about.
- undef $Q;
- $BEEN_THERE = 0;
- $DTD_PUBLIC_IDENTIFIER = "";
- undef @QUERY_PARAM;
- undef %EXPORT;
- undef $QUERY_CHARSET;
- undef %QUERY_FIELDNAMES;
- undef %QUERY_TMPFILES;
-
- # prevent complaints by mod_perl
- 1;
-}
-
-# ------------------ START OF THE LIBRARY ------------
-
-# make mod_perlhappy
-initialize_globals();
-
-# FIGURE OUT THE OS WE'RE RUNNING UNDER
-# Some systems support the $^O variable. If not
-# available then require() the Config library
-unless ($OS) {
- unless ($OS = $^O) {
- require Config;
- $OS = $Config::Config{'osname'};
- }
-}
-if ($OS =~ /^MSWin/i) {
- $OS = 'WINDOWS';
-} elsif ($OS =~ /^VMS/i) {
- $OS = 'VMS';
-} elsif ($OS =~ /^dos/i) {
- $OS = 'DOS';
-} elsif ($OS =~ /^MacOS/i) {
- $OS = 'MACINTOSH';
-} elsif ($OS =~ /^os2/i) {
- $OS = 'OS2';
-} elsif ($OS =~ /^epoc/i) {
- $OS = 'EPOC';
-} elsif ($OS =~ /^cygwin/i) {
- $OS = 'CYGWIN';
-} elsif ($OS =~ /^NetWare/i) {
- $OS = 'NETWARE';
-} else {
- $OS = 'UNIX';
-}
-
-# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN|NETWARE)/;
-
-# This is the default class for the CGI object to use when all else fails.
-$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
-
-# This is where to look for autoloaded routines.
-$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
-
-# The path separator is a slash, backslash or semicolon, depending
-# on the platform.
-$SL = {
- UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', NETWARE => '/',
- WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
- }->{$OS};
-
-# This no longer seems to be necessary
-# Turn on NPH scripts by default when running under IIS server!
-# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
-$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
-
-# Turn on special checking for ActiveState's PerlEx
-$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
-
-# Turn on special checking for Doug MacEachern's modperl
-# PerlEx::DBI tries to fool DBI by setting MOD_PERL
-if (exists $ENV{MOD_PERL} && ! $PERLEX) {
- # mod_perl handlers may run system() on scripts using CGI.pm;
- # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
- if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
- $MOD_PERL = 2;
- require Apache2::Response;
- require Apache2::RequestRec;
- require Apache2::RequestUtil;
- require Apache2::RequestIO;
- require APR::Pool;
- } else {
- $MOD_PERL = 1;
- require Apache;
- }
-}
-
-# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
-# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
-# and sometimes CR). The most popular VMS web server
-# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
-# use ASCII, so \015\012 means something different. I find this all
-# really annoying.
-$EBCDIC = "\t" ne "\011";
-if ($OS eq 'VMS') {
- $CRLF = "\n";
-} elsif ($EBCDIC) {
- $CRLF= "\r\n";
-} else {
- $CRLF = "\015\012";
-}
-
-if ($needs_binmode) {
- $CGI::DefaultClass->binmode(\*main::STDOUT);
- $CGI::DefaultClass->binmode(\*main::STDIN);
- $CGI::DefaultClass->binmode(\*main::STDERR);
-}
-
-%EXPORT_TAGS = (
- ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
- tt u i b blockquote pre img a address cite samp dfn html head
- base body Link nextid title meta kbd start_html end_html
- input Select option comment charset escapeHTML/],
- ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr
- embed basefont style span layer ilayer font frameset frame script small big Area Map/],
- ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
- ins label legend noframes noscript object optgroup Q
- thead tbody tfoot/],
- ':netscape'=>[qw/blink fontsize center/],
- ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
- submit reset defaults radio_group popup_menu button autoEscape
- scrolling_list image_button start_form end_form startform endform
- start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
- ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
- cookie Dump
- raw_cookie request_method query_string Accept user_agent remote_host content_type
- remote_addr referer server_name server_software server_port server_protocol virtual_port
- virtual_host remote_ident auth_type http append
- save_parameters restore_parameters param_fetch
- remote_user user_name header redirect import_names put
- Delete Delete_all url_param cgi_error/],
- ':ssl' => [qw/https/],
- ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
- ':html' => [qw/:html2 :html3 :html4 :netscape/],
- ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
- ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
- ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
- );
-
-# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
-# Author: Cees Hek <cees@sitesuite.com.au>
-
-sub can {
- my($class, $method) = @_;
-
- # See if UNIVERSAL::can finds it.
-
- if (my $func = $class -> SUPER::can($method) ){
- return $func;
- }
-
- # Try to compile the function.
-
- eval {
- # _compile looks at $AUTOLOAD for the function name.
-
- local $AUTOLOAD = join "::", $class, $method;
- &_compile;
- };
-
- # Now that the function is loaded (if it exists)
- # just use UNIVERSAL::can again to do the work.
-
- return $class -> SUPER::can($method);
-}
-
-# to import symbols into caller
-sub import {
- my $self = shift;
-
- # This causes modules to clash.
- undef %EXPORT_OK;
- undef %EXPORT;
-
- $self->_setup_symbols(@_);
- my ($callpack, $callfile, $callline) = caller;
-
- # To allow overriding, search through the packages
- # Till we find one in which the correct subroutine is defined.
- my @packages = ($self,@{"$self\:\:ISA"});
- for $sym (keys %EXPORT) {
- my $pck;
- my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
- for $pck (@packages) {
- if (defined(&{"$pck\:\:$sym"})) {
- $def = $pck;
- last;
- }
- }
- *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
- }
-}
-
-sub compile {
- my $pack = shift;
- $pack->_setup_symbols('-compile',@_);
-}
-
-sub expand_tags {
- my($tag) = @_;
- return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
- my(@r);
- return ($tag) unless $EXPORT_TAGS{$tag};
- for (@{$EXPORT_TAGS{$tag}}) {
- push(@r,&expand_tags($_));
- }
- return @r;
-}
-
-#### Method: new
-# The new routine. This will check the current environment
-# for an existing query string, and initialize itself, if so.
-####
-sub new {
- my($class,@initializer) = @_;
- my $self = {};
-
- bless $self,ref $class || $class || $DefaultClass;
-
- # always use a tempfile
- $self->{'use_tempfile'} = 1;
-
- if (ref($initializer[0])
- && (UNIVERSAL::isa($initializer[0],'Apache')
- ||
- UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
- )) {
- $self->r(shift @initializer);
- }
- if (ref($initializer[0])
- && (UNIVERSAL::isa($initializer[0],'CODE'))) {
- $self->upload_hook(shift @initializer, shift @initializer);
- $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
- }
- if ($MOD_PERL) {
- if ($MOD_PERL == 1) {
- $self->r(Apache->request) unless $self->r;
- my $r = $self->r;
- $r->register_cleanup(\&CGI::_reset_globals);
- $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
- }
- else {
- # XXX: once we have the new API
- # will do a real PerlOptions -SetupEnv check
- $self->r(Apache2::RequestUtil->request) unless $self->r;
- my $r = $self->r;
- $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
- $r->pool->cleanup_register(\&CGI::_reset_globals);
- $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
- }
- undef $NPH;
- }
- $self->_reset_globals if $PERLEX;
- $self->init(@initializer);
- return $self;
-}
-
-# We provide a DESTROY method so that we can ensure that
-# temporary files are closed (via Fh->DESTROY) before they
-# are unlinked (via CGITempFile->DESTROY) because it is not
-# possible to unlink an open file on Win32. We explicitly
-# call DESTROY on each, rather than just undefing them and
-# letting Perl DESTROY them by garbage collection, in case the
-# user is still holding any reference to them as well.
-sub DESTROY {
- my $self = shift;
- if ($OS eq 'WINDOWS' || $OS eq 'VMS') {
- for my $href (values %{$self->{'.tmpfiles'}}) {
- $href->{hndl}->DESTROY if defined $href->{hndl};
- $href->{name}->DESTROY if defined $href->{name};
- }
- }
-}
-
-sub r {
- my $self = shift;
- my $r = $self->{'.r'};
- $self->{'.r'} = shift if @_;
- $r;
-}
-
-sub upload_hook {
- my $self;
- if (ref $_[0] eq 'CODE') {
- $CGI::Q = $self = $CGI::DefaultClass->new(@_);
- } else {
- $self = shift;
- }
- my ($hook,$data,$use_tempfile) = @_;
- $self->{'.upload_hook'} = $hook;
- $self->{'.upload_data'} = $data;
- $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
-}
-
-#### Method: param
-# Returns the value(s)of a named parameter.
-# If invoked in a list context, returns the
-# entire list. Otherwise returns the first
-# member of the list.
-# If name is not provided, return a list of all
-# the known parameters names available.
-# If more than one argument is provided, the
-# second and subsequent arguments are used to
-# set the value of the parameter.
-####
-sub param {
- my($self,@p) = self_or_default(@_);
- return $self->all_parameters unless @p;
- my($name,$value,@other);
-
- # For compatibility between old calling style and use_named_parameters() style,
- # we have to special case for a single parameter present.
- if (@p > 1) {
- ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
- my(@values);
-
- if (substr($p[0],0,1) eq '-') {
- @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
- } else {
- for ($value,@other) {
- push(@values,$_) if defined($_);
- }
- }
- # If values is provided, then we set it.
- if (@values or defined $value) {
- $self->add_parameter($name);
- $self->{param}{$name}=[@values];
- }
- } else {
- $name = $p[0];
- }
-
- return unless defined($name) && $self->{param}{$name};
-
- my @result = @{$self->{param}{$name}};
-
- if ($PARAM_UTF8) {
- eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
- @result = map {ref $_ ? $_ : $self->_decode_utf8($_) } @result;
- }
-
- return wantarray ? @result : $result[0];
-}
-
-sub _decode_utf8 {
- my ($self, $val) = @_;
-
- if (Encode::is_utf8($val)) {
- return $val;
- }
- else {
- return Encode::decode(utf8 => $val);
- }
-}
-
-sub self_or_default {
- return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
- unless (defined($_[0]) &&
- (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
- ) {
- $Q = $CGI::DefaultClass->new unless defined($Q);
- unshift(@_,$Q);
- }
- return wantarray ? @_ : $Q;
-}
-
-sub self_or_CGI {
- local $^W=0; # prevent a warning
- if (defined($_[0]) &&
- (substr(ref($_[0]),0,3) eq 'CGI'
- || UNIVERSAL::isa($_[0],'CGI'))) {
- return @_;
- } else {
- return ($DefaultClass,@_);
- }
-}
-
-########################################
-# THESE METHODS ARE MORE OR LESS PRIVATE
-# GO TO THE __DATA__ SECTION TO SEE MORE
-# PUBLIC METHODS
-########################################
-
-# Initialize the query object from the environment.
-# If a parameter list is found, this object will be set
-# to a hash in which parameter names are keys
-# and the values are stored as lists
-# If a keyword list is found, this method creates a bogus
-# parameter list with the single parameter 'keywords'.
-
-sub init {
- my $self = shift;
- my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
-
- my $is_xforms;
-
- my $initializer = shift; # for backward compatibility
- local($/) = "\n";
-
- # set autoescaping on by default
- $self->{'escape'} = 1;
-
- # if we get called more than once, we want to initialize
- # ourselves from the original query (which may be gone
- # if it was read from STDIN originally.)
- if (@QUERY_PARAM && !defined($initializer)) {
- for my $name (@QUERY_PARAM) {
- my $val = $QUERY_PARAM{$name}; # always an arrayref;
- $self->param('-name'=>$name,'-value'=> $val);
- if (defined $val and ref $val eq 'ARRAY') {
- for my $fh (grep {defined($_) && ref($_) && defined(fileno($_))} @$val) {
- seek($fh,0,0); # reset the filehandle.
- }
-
- }
- }
- $self->charset($QUERY_CHARSET);
- $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
- $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
- return;
- }
-
- $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
- $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
-
- $fh = to_filehandle($initializer) if $initializer;
-
- # set charset to the safe ISO-8859-1
- $self->charset('ISO-8859-1');
-
- METHOD: {
-
- # avoid unreasonably large postings
- if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
- #discard the post, unread
- $self->cgi_error("413 Request entity too large");
- last METHOD;
- }
-
- # Process multipart postings, but only if the initializer is
- # not defined.
- if ($meth eq 'POST'
- && defined($ENV{'CONTENT_TYPE'})
- && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
- && !defined($initializer)
- ) {
- my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
- $self->read_multipart($boundary,$content_length);
- last METHOD;
- }
-
- # Process XForms postings. We know that we have XForms in the
- # following cases:
- # method eq 'POST' && content-type eq 'application/xml'
- # method eq 'POST' && content-type =~ /multipart\/related.+start=/
- # There are more cases, actually, but for now, we don't support other
- # methods for XForm posts.
- # In a XForm POST, the QUERY_STRING is parsed normally.
- # If the content-type is 'application/xml', we just set the param
- # XForms:Model (referring to the xml syntax) param containing the
- # unparsed XML data.
- # In the case of multipart/related we set XForms:Model as above, but
- # the other parts are available as uploads with the Content-ID as the
- # the key.
- # See the URL below for XForms specs on this issue.
- # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
- if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
- if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
- my($param) = 'XForms:Model';
- my($value) = '';
- $self->add_parameter($param);
- $self->read_from_client(\$value,$content_length,0)
- if $content_length > 0;
- push (@{$self->{param}{$param}},$value);
- $is_xforms = 1;
- } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
- my($boundary,$start) = ($1,$2);
- my($param) = 'XForms:Model';
- $self->add_parameter($param);
- my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
- push (@{$self->{param}{$param}},$value);
- if ($MOD_PERL) {
- $query_string = $self->r->args;
- } else {
- $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
- $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
- }
- $is_xforms = 1;
- }
- }
-
-
- # If initializer is defined, then read parameters
- # from it.
- if (!$is_xforms && defined($initializer)) {
- if (UNIVERSAL::isa($initializer,'CGI')) {
- $query_string = $initializer->query_string;
- last METHOD;
- }
- if (ref($initializer) && ref($initializer) eq 'HASH') {
- for (keys %$initializer) {
- $self->param('-name'=>$_,'-value'=>$initializer->{$_});
- }
- last METHOD;
- }
-
- if (defined($fh) && ($fh ne '')) {
- while (my $line = <$fh>) {
- chomp $line;
- last if $line =~ /^=$/;
- push(@lines,$line);
- }
- # massage back into standard format
- if ("@lines" =~ /=/) {
- $query_string=join("&",@lines);
- } else {
- $query_string=join("+",@lines);
- }
- last METHOD;
- }
-
- # last chance -- treat it as a string
- $initializer = $$initializer if ref($initializer) eq 'SCALAR';
- $query_string = $initializer;
-
- last METHOD;
- }
-
- # If method is GET, HEAD or DELETE, fetch the query from
- # the environment.
- if ($is_xforms || $meth=~/^(GET|HEAD|DELETE)$/) {
- if ($MOD_PERL) {
- $query_string = $self->r->args;
- } else {
- $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
- $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
- }
- last METHOD;
- }
-
- if ($meth eq 'POST' || $meth eq 'PUT') {
- if ( $content_length > 0 ) {
- $self->read_from_client(\$query_string,$content_length,0);
- }
- # Some people want to have their cake and eat it too!
- # Uncomment this line to have the contents of the query string
- # APPENDED to the POST data.
- # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
- last METHOD;
- }
-
- # If $meth is not of GET, POST, PUT or HEAD, assume we're
- # being debugged offline.
- # Check the command line and then the standard input for data.
- # We use the shellwords package in order to behave the way that
- # UN*X programmers expect.
- if ($DEBUG)
- {
- my $cmdline_ret = read_from_cmdline();
- $query_string = $cmdline_ret->{'query_string'};
- if (defined($cmdline_ret->{'subpath'}))
- {
- $self->path_info($cmdline_ret->{'subpath'});
- }
- }
- }
-
-# YL: Begin Change for XML handler 10/19/2001
- if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
- && defined($ENV{'CONTENT_TYPE'})
- && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
- && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
- my($param) = $meth . 'DATA' ;
- $self->add_parameter($param) ;
- push (@{$self->{param}{$param}},$query_string);
- undef $query_string ;
- }
-# YL: End Change for XML handler 10/19/2001
-
- # We now have the query string in hand. We do slightly
- # different things for keyword lists and parameter lists.
- if (defined $query_string && length $query_string) {
- if ($query_string =~ /[&=;]/) {
- $self->parse_params($query_string);
- } else {
- $self->add_parameter('keywords');
- $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)];
- }
- }
-
- # Special case. Erase everything if there is a field named
- # .defaults.
- if ($self->param('.defaults')) {
- $self->delete_all();
- }
-
- # hash containing our defined fieldnames
- $self->{'.fieldnames'} = {};
- for ($self->param('.cgifields')) {
- $self->{'.fieldnames'}->{$_}++;
- }
-
- # Clear out our default submission button flag if present
- $self->delete('.submit');
- $self->delete('.cgifields');
-
- $self->save_request unless defined $initializer;
-}
-
-# FUNCTIONS TO OVERRIDE:
-# Turn a string into a filehandle
-sub to_filehandle {
- my $thingy = shift;
- return undef unless $thingy;
- return $thingy if UNIVERSAL::isa($thingy,'GLOB');
- return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
- if (!ref($thingy)) {
- my $caller = 1;
- while (my $package = caller($caller++)) {
- my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
- return $tmp if defined(fileno($tmp));
- }
- }
- return undef;
-}
-
-# send output to the browser
-sub put {
- my($self,@p) = self_or_default(@_);
- $self->print(@p);
-}
-
-# print to standard output (for overriding in mod_perl)
-sub print {
- shift;
- CORE::print(@_);
-}
-
-# get/set last cgi_error
-sub cgi_error {
- my ($self,$err) = self_or_default(@_);
- $self->{'.cgi_error'} = $err if defined $err;
- return $self->{'.cgi_error'};
-}
-
-sub save_request {
- my($self) = @_;
- # We're going to play with the package globals now so that if we get called
- # again, we initialize ourselves in exactly the same way. This allows
- # us to have several of these objects.
- @QUERY_PARAM = $self->param; # save list of parameters
- for (@QUERY_PARAM) {
- next unless defined $_;
- $QUERY_PARAM{$_}=$self->{param}{$_};
- }
- $QUERY_CHARSET = $self->charset;
- %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
- %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
-}
-
-sub parse_params {
- my($self,$tosplit) = @_;
- my(@pairs) = split(/[&;]/,$tosplit);
- my($param,$value);
- for (@pairs) {
- ($param,$value) = split('=',$_,2);
- next unless defined $param;
- next if $NO_UNDEF_PARAMS and not defined $value;
- $value = '' unless defined $value;
- $param = unescape($param);
- $value = unescape($value);
- $self->add_parameter($param);
- push (@{$self->{param}{$param}},$value);
- }
-}
-
-sub add_parameter {
- my($self,$param)=@_;
- return unless defined $param;
- push (@{$self->{'.parameters'}},$param)
- unless defined($self->{param}{$param});
-}
-
-sub all_parameters {
- my $self = shift;
- return () unless defined($self) && $self->{'.parameters'};
- return () unless @{$self->{'.parameters'}};
- return @{$self->{'.parameters'}};
-}
-
-# put a filehandle into binary mode (DOS)
-sub binmode {
- return unless defined($_[1]) && ref ($_[1]) && defined fileno($_[1]);
- CORE::binmode($_[1]);
-}
-
-sub _make_tag_func {
- my ($self,$tagname) = @_;
- my $func = qq(
- sub $tagname {
- my (\$q,\$a,\@rest) = self_or_default(\@_);
- my(\$attr) = '';
- if (ref(\$a) && ref(\$a) eq 'HASH') {
- my(\@attr) = make_attributes(\$a,\$q->{'escape'});
- \$attr = " \@attr" if \@attr;
- } else {
- unshift \@rest,\$a if defined \$a;
- }
- );
- if ($tagname=~/start_(\w+)/i) {
- $func .= qq! return "<\L$1\E\$attr>";} !;
- } elsif ($tagname=~/end_(\w+)/i) {
- $func .= qq! return "<\L/$1\E>"; } !;
- } else {
- $func .= qq#
- return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
- my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
- my \@result = map { "\$tag\$_\$untag" }
- (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
- return "\@result";
- }#;
- }
-return $func;
-}
-
-sub AUTOLOAD {
- print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
- my $func = &_compile;
- goto &$func;
-}
-
-sub _compile {
- my($func) = $AUTOLOAD;
- my($pack,$func_name);
- {
- local($1,$2); # this fixes an obscure variable suicide problem.
- $func=~/(.+)::([^:]+)$/;
- ($pack,$func_name) = ($1,$2);
- $pack=~s/::SUPER$//; # fix another obscure problem
- $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
- unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
-
- my($sub) = \%{"$pack\:\:SUBS"};
- unless (%$sub) {
- my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
- local ($@,$!);
- eval "package $pack; $$auto";
- croak("$AUTOLOAD: $@") if $@;
- $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
- }
- my($code) = $sub->{$func_name};
-
- $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
- if (!$code) {
- (my $base = $func_name) =~ s/^(start_|end_)//i;
- if ($EXPORT{':any'} ||
- $EXPORT{'-any'} ||
- $EXPORT{$base} ||
- (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
- && $EXPORT_OK{$base}) {
- $code = $CGI::DefaultClass->_make_tag_func($func_name);
- }
- }
- croak("Undefined subroutine $AUTOLOAD\n") unless $code;
- local ($@,$!);
- eval "package $pack; $code";
- if ($@) {
- $@ =~ s/ at .*\n//;
- croak("$AUTOLOAD: $@");
- }
- }
- CORE::delete($sub->{$func_name}); #free storage
- return "$pack\:\:$func_name";
-}
-
-sub _selected {
- my $self = shift;
- my $value = shift;
- return '' unless $value;
- return $XHTML ? qq(selected="selected" ) : qq(selected );
-}
-
-sub _checked {
- my $self = shift;
- my $value = shift;
- return '' unless $value;
- return $XHTML ? qq(checked="checked" ) : qq(checked );
-}
-
-sub _reset_globals { initialize_globals(); }
-
-sub _setup_symbols {
- my $self = shift;
- my $compile = 0;
-
- # to avoid reexporting unwanted variables
- undef %EXPORT;
-
- for (@_) {
- $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
- $NPH++, next if /^[:-]nph$/;
- $NOSTICKY++, next if /^[:-]nosticky$/;
- $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
- $DEBUG=2, next if /^[:-][Dd]ebug$/;
- $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
- $PARAM_UTF8++, next if /^[:-]utf8$/;
- $XHTML++, next if /^[:-]xhtml$/;
- $XHTML=0, next if /^[:-]no_?xhtml$/;
- $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
- $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
- $TABINDEX++, next if /^[:-]tabindex$/;
- $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
- $EXPORT{$_}++, next if /^[:-]any$/;
- $compile++, next if /^[:-]compile$/;
- $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
-
- # This is probably extremely evil code -- to be deleted some day.
- if (/^[-]autoload$/) {
- my($pkg) = caller(1);
- *{"${pkg}::AUTOLOAD"} = sub {
- my($routine) = $AUTOLOAD;
- $routine =~ s/^.*::/CGI::/;
- &$routine;
- };
- next;
- }
-
- for (&expand_tags($_)) {
- tr/a-zA-Z0-9_//cd; # don't allow weird function names
- $EXPORT{$_}++;
- }
- }
- _compile_all(keys %EXPORT) if $compile;
- @SAVED_SYMBOLS = @_;
-}
-
-sub charset {
- my ($self,$charset) = self_or_default(@_);
- $self->{'.charset'} = $charset if defined $charset;
- $self->{'.charset'};
-}
-
-sub element_id {
- my ($self,$new_value) = self_or_default(@_);
- $self->{'.elid'} = $new_value if defined $new_value;
- sprintf('%010d',$self->{'.elid'}++);
-}
-
-sub element_tab {
- my ($self,$new_value) = self_or_default(@_);
- $self->{'.etab'} ||= 1;
- $self->{'.etab'} = $new_value if defined $new_value;
- my $tab = $self->{'.etab'}++;
- return '' unless $TABINDEX or defined $new_value;
- return qq(tabindex="$tab" );
-}
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-
-%SUBS = (
-
-'URL_ENCODED'=> <<'END_OF_FUNC',
-sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
-END_OF_FUNC
-
-'MULTIPART' => <<'END_OF_FUNC',
-sub MULTIPART { 'multipart/form-data'; }
-END_OF_FUNC
-
-'SERVER_PUSH' => <<'END_OF_FUNC',
-sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
-END_OF_FUNC
-
-'new_MultipartBuffer' => <<'END_OF_FUNC',
-# Create a new multipart buffer
-sub new_MultipartBuffer {
- my($self,$boundary,$length) = @_;
- return MultipartBuffer->new($self,$boundary,$length);
-}
-END_OF_FUNC
-
-'read_from_client' => <<'END_OF_FUNC',
-# Read data from a file handle
-sub read_from_client {
- my($self, $buff, $len, $offset) = @_;
- local $^W=0; # prevent a warning
- return $MOD_PERL
- ? $self->r->read($$buff, $len, $offset)
- : read(\*STDIN, $$buff, $len, $offset);
-}
-END_OF_FUNC
-
-'delete' => <<'END_OF_FUNC',
-#### Method: delete
-# Deletes the named parameter entirely.
-####
-sub delete {
- my($self,@p) = self_or_default(@_);
- my(@names) = rearrange([NAME],@p);
- my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
- my %to_delete;
- for my $name (@to_delete)
- {
- CORE::delete $self->{param}{$name};
- CORE::delete $self->{'.fieldnames'}->{$name};
- $to_delete{$name}++;
- }
- @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
- return;
-}
-END_OF_FUNC
-
-#### Method: import_names
-# Import all parameters into the given namespace.
-# Assumes namespace 'Q' if not specified
-####
-'import_names' => <<'END_OF_FUNC',
-sub import_names {
- my($self,$namespace,$delete) = self_or_default(@_);
- $namespace = 'Q' unless defined($namespace);
- die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
- if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
- # can anyone find an easier way to do this?
- for (keys %{"${namespace}::"}) {
- local *symbol = "${namespace}::${_}";
- undef $symbol;
- undef @symbol;
- undef %symbol;
- }
- }
- my($param,@value,$var);
- for $param ($self->param) {
- # protect against silly names
- ($var = $param)=~tr/a-zA-Z0-9_/_/c;
- $var =~ s/^(?=\d)/_/;
- local *symbol = "${namespace}::$var";
- @value = $self->param($param);
- @symbol = @value;
- $symbol = $value[0];
- }
-}
-END_OF_FUNC
-
-#### Method: keywords
-# Keywords acts a bit differently. Calling it in a list context
-# returns the list of keywords.
-# Calling it in a scalar context gives you the size of the list.
-####
-'keywords' => <<'END_OF_FUNC',
-sub keywords {
- my($self,@values) = self_or_default(@_);
- # If values is provided, then we set it.
- $self->{param}{'keywords'}=[@values] if @values;
- my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
- @result;
-}
-END_OF_FUNC
-
-# These are some tie() interfaces for compatibility
-# with Steve Brenner's cgi-lib.pl routines
-'Vars' => <<'END_OF_FUNC',
-sub Vars {
- my $q = shift;
- my %in;
- tie(%in,CGI,$q);
- return %in if wantarray;
- return \%in;
-}
-END_OF_FUNC
-
-# These are some tie() interfaces for compatibility
-# with Steve Brenner's cgi-lib.pl routines
-'ReadParse' => <<'END_OF_FUNC',
-sub ReadParse {
- local(*in);
- if (@_) {
- *in = $_[0];
- } else {
- my $pkg = caller();
- *in=*{"${pkg}::in"};
- }
- tie(%in,CGI);
- return scalar(keys %in);
-}
-END_OF_FUNC
-
-'PrintHeader' => <<'END_OF_FUNC',
-sub PrintHeader {
- my($self) = self_or_default(@_);
- return $self->header();
-}
-END_OF_FUNC
-
-'HtmlTop' => <<'END_OF_FUNC',
-sub HtmlTop {
- my($self,@p) = self_or_default(@_);
- return $self->start_html(@p);
-}
-END_OF_FUNC
-
-'HtmlBot' => <<'END_OF_FUNC',
-sub HtmlBot {
- my($self,@p) = self_or_default(@_);
- return $self->end_html(@p);
-}
-END_OF_FUNC
-
-'SplitParam' => <<'END_OF_FUNC',
-sub SplitParam {
- my ($param) = @_;
- my (@params) = split ("\0", $param);
- return (wantarray ? @params : $params[0]);
-}
-END_OF_FUNC
-
-'MethGet' => <<'END_OF_FUNC',
-sub MethGet {
- return request_method() eq 'GET';
-}
-END_OF_FUNC
-
-'MethPost' => <<'END_OF_FUNC',
-sub MethPost {
- return request_method() eq 'POST';
-}
-END_OF_FUNC
-
-'MethPut' => <<'END_OF_FUNC',
-sub MethPut {
- return request_method() eq 'PUT';
-}
-END_OF_FUNC
-
-'TIEHASH' => <<'END_OF_FUNC',
-sub TIEHASH {
- my $class = shift;
- my $arg = $_[0];
- if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
- return $arg;
- }
- return $Q ||= $class->new(@_);
-}
-END_OF_FUNC
-
-'STORE' => <<'END_OF_FUNC',
-sub STORE {
- my $self = shift;
- my $tag = shift;
- my $vals = shift;
- my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
- $self->param(-name=>$tag,-value=>\@vals);
-}
-END_OF_FUNC
-
-'FETCH' => <<'END_OF_FUNC',
-sub FETCH {
- return $_[0] if $_[1] eq 'CGI';
- return undef unless defined $_[0]->param($_[1]);
- return join("\0",$_[0]->param($_[1]));
-}
-END_OF_FUNC
-
-'FIRSTKEY' => <<'END_OF_FUNC',
-sub FIRSTKEY {
- $_[0]->{'.iterator'}=0;
- $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
-}
-END_OF_FUNC
-
-'NEXTKEY' => <<'END_OF_FUNC',
-sub NEXTKEY {
- $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
-}
-END_OF_FUNC
-
-'EXISTS' => <<'END_OF_FUNC',
-sub EXISTS {
- exists $_[0]->{param}{$_[1]};
-}
-END_OF_FUNC
-
-'DELETE' => <<'END_OF_FUNC',
-sub DELETE {
- $_[0]->delete($_[1]);
-}
-END_OF_FUNC
-
-'CLEAR' => <<'END_OF_FUNC',
-sub CLEAR {
- %{$_[0]}=();
-}
-####
-END_OF_FUNC
-
-####
-# Append a new value to an existing query
-####
-'append' => <<'EOF',
-sub append {
- my($self,@p) = self_or_default(@_);
- my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
- my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
- if (@values) {
- $self->add_parameter($name);
- push(@{$self->{param}{$name}},@values);
- }
- return $self->param($name);
-}
-EOF
-
-#### Method: delete_all
-# Delete all parameters
-####
-'delete_all' => <<'EOF',
-sub delete_all {
- my($self) = self_or_default(@_);
- my @param = $self->param();
- $self->delete(@param);
-}
-EOF
-
-'Delete' => <<'EOF',
-sub Delete {
- my($self,@p) = self_or_default(@_);
- $self->delete(@p);
-}
-EOF
-
-'Delete_all' => <<'EOF',
-sub Delete_all {
- my($self,@p) = self_or_default(@_);
- $self->delete_all(@p);
-}
-EOF
-
-#### Method: autoescape
-# If you want to turn off the autoescaping features,
-# call this method with undef as the argument
-'autoEscape' => <<'END_OF_FUNC',
-sub autoEscape {
- my($self,$escape) = self_or_default(@_);
- my $d = $self->{'escape'};
- $self->{'escape'} = $escape;
- $d;
-}
-END_OF_FUNC
-
-
-#### Method: version
-# Return the current version
-####
-'version' => <<'END_OF_FUNC',
-sub version {
- return $VERSION;
-}
-END_OF_FUNC
-
-#### Method: url_param
-# Return a parameter in the QUERY_STRING, regardless of
-# whether this was a POST or a GET
-####
-'url_param' => <<'END_OF_FUNC',
-sub url_param {
- my ($self,@p) = self_or_default(@_);
- my $name = shift(@p);
- return undef unless exists($ENV{QUERY_STRING});
- unless (exists($self->{'.url_param'})) {
- $self->{'.url_param'}={}; # empty hash
- if ($ENV{QUERY_STRING} =~ /=/) {
- my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
- my($param,$value);
- for (@pairs) {
- ($param,$value) = split('=',$_,2);
- $param = unescape($param);
- $value = unescape($value);
- push(@{$self->{'.url_param'}->{$param}},$value);
- }
- } else {
- my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING});
- $self->{'.url_param'}{'keywords'} = \@keywords if @keywords;
- }
- }
- return keys %{$self->{'.url_param'}} unless defined($name);
- return () unless $self->{'.url_param'}->{$name};
- return wantarray ? @{$self->{'.url_param'}->{$name}}
- : $self->{'.url_param'}->{$name}->[0];
-}
-END_OF_FUNC
-
-#### Method: Dump
-# Returns a string in which all the known parameter/value
-# pairs are represented as nested lists, mainly for the purposes
-# of debugging.
-####
-'Dump' => <<'END_OF_FUNC',
-sub Dump {
- my($self) = self_or_default(@_);
- my($param,$value,@result);
- return '<ul></ul>' unless $self->param;
- push(@result,"<ul>");
- for $param ($self->param) {
- my($name)=$self->_maybe_escapeHTML($param);
- push(@result,"<li><strong>$name</strong></li>");
- push(@result,"<ul>");
- for $value ($self->param($param)) {
- $value = $self->_maybe_escapeHTML($value);
- $value =~ s/\n/<br \/>\n/g;
- push(@result,"<li>$value</li>");
- }
- push(@result,"</ul>");
- }
- push(@result,"</ul>");
- return join("\n",@result);
-}
-END_OF_FUNC
-
-#### Method as_string
-#
-# synonym for "dump"
-####
-'as_string' => <<'END_OF_FUNC',
-sub as_string {
- &Dump(@_);
-}
-END_OF_FUNC
-
-#### Method: save
-# Write values out to a filehandle in such a way that they can
-# be reinitialized by the filehandle form of the new() method
-####
-'save' => <<'END_OF_FUNC',
-sub save {
- my($self,$filehandle) = self_or_default(@_);
- $filehandle = to_filehandle($filehandle);
- my($param);
- local($,) = ''; # set print field separator back to a sane value
- local($\) = ''; # set output line separator to a sane value
- for $param ($self->param) {
- my($escaped_param) = escape($param);
- my($value);
- for $value ($self->param($param)) {
- print $filehandle "$escaped_param=",escape("$value"),"\n"
- if length($escaped_param) or length($value);
- }
- }
- for (keys %{$self->{'.fieldnames'}}) {
- print $filehandle ".cgifields=",escape("$_"),"\n";
- }
- print $filehandle "=\n"; # end of record
-}
-END_OF_FUNC
-
-
-#### Method: save_parameters
-# An alias for save() that is a better name for exportation.
-# Only intended to be used with the function (non-OO) interface.
-####
-'save_parameters' => <<'END_OF_FUNC',
-sub save_parameters {
- my $fh = shift;
- return save(to_filehandle($fh));
-}
-END_OF_FUNC
-
-#### Method: restore_parameters
-# A way to restore CGI parameters from an initializer.
-# Only intended to be used with the function (non-OO) interface.
-####
-'restore_parameters' => <<'END_OF_FUNC',
-sub restore_parameters {
- $Q = $CGI::DefaultClass->new(@_);
-}
-END_OF_FUNC
-
-#### Method: multipart_init
-# Return a Content-Type: style header for server-push
-# This has to be NPH on most web servers, and it is advisable to set $| = 1
-#
-# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution, updated by Andrew Benham (adsb@bigfoot.com)
-####
-'multipart_init' => <<'END_OF_FUNC',
-sub multipart_init {
- my($self,@p) = self_or_default(@_);
- my($boundary,@other) = rearrange_header([BOUNDARY],@p);
- if (!$boundary) {
- $boundary = '------- =_';
- my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z');
- for (1..17) {
- $boundary .= $chrs[rand(scalar @chrs)];
- }
- }
-
- $self->{'separator'} = "$CRLF--$boundary$CRLF";
- $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
- $type = SERVER_PUSH($boundary);
- return $self->header(
- -nph => 0,
- -type => $type,
- (map { split "=", $_, 2 } @other),
- ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
-}
-END_OF_FUNC
-
-
-#### Method: multipart_start
-# Return a Content-Type: style header for server-push, start of section
-#
-# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution, updated by Andrew Benham (adsb@bigfoot.com)
-####
-'multipart_start' => <<'END_OF_FUNC',
-sub multipart_start {
- my(@header);
- my($self,@p) = self_or_default(@_);
- my($type,@other) = rearrange([TYPE],@p);
- $type = $type || 'text/html';
- push(@header,"Content-Type: $type");
-
- # rearrange() was designed for the HTML portion, so we
- # need to fix it up a little.
- for (@other) {
- # Don't use \s because of perl bug 21951
- next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
- ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
- }
- push(@header,@other);
- my $header = join($CRLF,@header)."${CRLF}${CRLF}";
- return $header;
-}
-END_OF_FUNC
-
-
-#### Method: multipart_end
-# Return a MIME boundary separator for server-push, end of section
-#
-# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
-####
-'multipart_end' => <<'END_OF_FUNC',
-sub multipart_end {
- my($self,@p) = self_or_default(@_);
- return $self->{'separator'};
-}
-END_OF_FUNC
-
-
-#### Method: multipart_final
-# Return a MIME boundary separator for server-push, end of all sections
-#
-# Contributed by Andrew Benham (adsb@bigfoot.com)
-####
-'multipart_final' => <<'END_OF_FUNC',
-sub multipart_final {
- my($self,@p) = self_or_default(@_);
- return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
-}
-END_OF_FUNC
-
-
-#### Method: header
-# Return a Content-Type: style header
-#
-####
-'header' => <<'END_OF_FUNC',
-sub header {
- my($self,@p) = self_or_default(@_);
- my(@header);
-
- return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
-
- my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
- rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
- 'STATUS',['COOKIE','COOKIES'],'TARGET',
- 'EXPIRES','NPH','CHARSET',
- 'ATTACHMENT','P3P'],@p);
-
- # Since $cookie and $p3p may be array references,
- # we must stringify them before CR escaping is done.
- my @cookie;
- for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) {
- my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
- push(@cookie,$cs) if defined $cs and $cs ne '';
- }
- $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
-
- # CR escaping for values, per RFC 822
- for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
- if (defined $header) {
- # From RFC 822:
- # Unfolding is accomplished by regarding CRLF immediately
- # followed by a LWSP-char as equivalent to the LWSP-char.
- $header =~ s/$CRLF(\s)/$1/g;
-
- # All other uses of newlines are invalid input.
- if ($header =~ m/$CRLF|\015|\012/) {
- # shorten very long values in the diagnostic
- $header = substr($header,0,72).'...' if (length $header > 72);
- die "Invalid header value contains a newline not followed by whitespace: $header";
- }
- }
- }
-
- $nph ||= $NPH;
-
- $type ||= 'text/html' unless defined($type);
-
- # sets if $charset is given, gets if not
- $charset = $self->charset( $charset );
-
- # rearrange() was designed for the HTML portion, so we
- # need to fix it up a little.
- for (@other) {
- # Don't use \s because of perl bug 21951
- next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
- ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
- }
-
- $type .= "; charset=$charset"
- if $type ne ''
- and $type !~ /\bcharset\b/
- and defined $charset
- and $charset ne '';
-
- # Maybe future compatibility. Maybe not.
- my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
- push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
- push(@header,"Server: " . &server_software()) if $nph;
-
- push(@header,"Status: $status") if $status;
- push(@header,"Window-Target: $target") if $target;
- push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p;
- # push all the cookies -- there may be several
- push(@header,map {"Set-Cookie: $_"} @cookie);
- # if the user indicates an expiration time, then we need
- # both an Expires and a Date header (so that the browser is
- # uses OUR clock)
- push(@header,"Expires: " . expires($expires,'http'))
- if $expires;
- push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
- push(@header,"Pragma: no-cache") if $self->cache();
- push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
- push(@header,map {ucfirst $_} @other);
- push(@header,"Content-Type: $type") if $type ne '';
- my $header = join($CRLF,@header)."${CRLF}${CRLF}";
- if (($MOD_PERL >= 1) && !$nph) {
- $self->r->send_cgi_header($header);
- return '';
- }
- return $header;
-}
-END_OF_FUNC
-
-#### Method: cache
-# Control whether header() will produce the no-cache
-# Pragma directive.
-####
-'cache' => <<'END_OF_FUNC',
-sub cache {
- my($self,$new_value) = self_or_default(@_);
- $new_value = '' unless $new_value;
- if ($new_value ne '') {
- $self->{'cache'} = $new_value;
- }
- return $self->{'cache'};
-}
-END_OF_FUNC
-
-
-#### Method: redirect
-# Return a Location: style header
-#
-####
-'redirect' => <<'END_OF_FUNC',
-sub redirect {
- my($self,@p) = self_or_default(@_);
- my($url,$target,$status,$cookie,$nph,@other) =
- rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
- $status = '302 Found' unless defined $status;
- $url ||= $self->self_url;
- my(@o);
- for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
- unshift(@o,
- '-Status' => $status,
- '-Location'=> $url,
- '-nph' => $nph);
- unshift(@o,'-Target'=>$target) if $target;
- unshift(@o,'-Type'=>'');
- my @unescaped;
- unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
- return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
-}
-END_OF_FUNC
-
-
-#### Method: start_html
-# Canned HTML header
-#
-# Parameters:
-# $title -> (optional) The title for this HTML document (-title)
-# $author -> (optional) e-mail address of the author (-author)
-# $base -> (optional) if set to true, will enter the BASE address of this document
-# for resolving relative references (-base)
-# $xbase -> (optional) alternative base at some remote location (-xbase)
-# $target -> (optional) target window to load all links into (-target)
-# $script -> (option) Javascript code (-script)
-# $no_script -> (option) Javascript <noscript> tag (-noscript)
-# $meta -> (optional) Meta information tags
-# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
-# (a scalar or array ref)
-# $style -> (optional) reference to an external style sheet
-# @other -> (optional) any other named parameters you'd like to incorporate into
-# the <body> tag.
-####
-'start_html' => <<'END_OF_FUNC',
-sub start_html {
- my($self,@p) = &self_or_default(@_);
- my($title,$author,$base,$xbase,$script,$noscript,
- $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
- rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
- META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
-
- $self->element_id(0);
- $self->element_tab(0);
-
- $encoding = lc($self->charset) unless defined $encoding;
-
- # Need to sort out the DTD before it's okay to call escapeHTML().
- my(@result,$xml_dtd);
- if ($dtd) {
- if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
- $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
- } else {
- $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
- }
- } else {
- $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
- }
-
- $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
- $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
- push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
-
- if (ref($dtd) && ref($dtd) eq 'ARRAY') {
- push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
- $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
- } else {
- push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
- $DTD_PUBLIC_IDENTIFIER = $dtd;
- }
-
- # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
- # call escapeHTML(). Strangely enough, the title needs to be escaped as
- # HTML while the author needs to be escaped as a URL.
- $title = $self->_maybe_escapeHTML($title || 'Untitled Document');
- $author = $self->escape($author);
-
- if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) {
- $lang = "" unless defined $lang;
- $XHTML = 0;
- }
- else {
- $lang = 'en-US' unless defined $lang;
- }
-
- my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
- my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
- if $XHTML && $encoding && !$declare_xml;
-
- push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
- : ($lang ? qq(<html lang="$lang">) : "<html>")
- . "<head><title>$title</title>");
- if (defined $author) {
- push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
- : "<link rev=\"made\" href=\"mailto:$author\">");
- }
-
- if ($base || $xbase || $target) {
- my $href = $xbase || $self->url('-path'=>1);
- my $t = $target ? qq/ target="$target"/ : '';
- push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
- }
-
- if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
- for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
- : qq(<meta name="$_" content="$meta->{$_}">)); }
- }
-
- my $meta_bits_set = 0;
- if( $head ) {
- if( ref $head ) {
- push @result, @$head;
- $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
- }
- else {
- push @result, $head;
- $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
- }
- }
-
- # handle the infrequently-used -style and -script parameters
- push(@result,$self->_style($style)) if defined $style;
- push(@result,$self->_script($script)) if defined $script;
- push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
-
- # handle -noscript parameter
- push(@result,<<END) if $noscript;
-<noscript>
-$noscript
-</noscript>
-END
- ;
- my($other) = @other ? " @other" : '';
- push(@result,"</head>\n<body$other>\n");
- return join("\n",@result);
-}
-END_OF_FUNC
-
-### Method: _style
-# internal method for generating a CSS style section
-####
-'_style' => <<'END_OF_FUNC',
-sub _style {
- my ($self,$style) = @_;
- my (@result);
-
- my $type = 'text/css';
- my $rel = 'stylesheet';
-
-
- my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
- my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
-
- my @s = ref($style) eq 'ARRAY' ? @$style : $style;
- my $other = '';
-
- for my $s (@s) {
- if (ref($s)) {
- my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
- rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
- ('-foo'=>'bar',
- ref($s) eq 'ARRAY' ? @$s : %$s));
- my $type = defined $stype ? $stype : 'text/css';
- my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
- $other = "@other" if @other;
-
- if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
- { # If it is, push a LINK tag for each one
- for $src (@$src)
- {
- push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
- : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
- }
- }
- else
- { # Otherwise, push the single -src, if it exists.
- push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
- : qq(<link rel="$rel" type="$type" href="$src"$other>)
- ) if $src;
- }
- if ($verbatim) {
- my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
- push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
- }
- my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
- push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
-
- } else {
- my $src = $s;
- push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
- : qq(<link rel="$rel" type="$type" href="$src"$other>));
- }
- }
- @result;
-}
-END_OF_FUNC
-
-'_script' => <<'END_OF_FUNC',
-sub _script {
- my ($self,$script) = @_;
- my (@result);
-
- my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
- for $script (@scripts) {
- my($src,$code,$language,$charset);
- if (ref($script)) { # script is a hash
- ($src,$code,$type,$charset) =
- rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($script) eq 'ARRAY' ? @$script : %$script);
- $type ||= 'text/javascript';
- unless ($type =~ m!\w+/\w+!) {
- $type =~ s/[\d.]+$//;
- $type = "text/$type";
- }
- } else {
- ($src,$code,$type,$charset) = ('',$script, 'text/javascript', '');
- }
-
- my $comment = '//'; # javascript by default
- $comment = '#' if $type=~/perl|tcl/i;
- $comment = "'" if $type=~/vbscript/i;
-
- my ($cdata_start,$cdata_end);
- if ($XHTML) {
- $cdata_start = "$comment<![CDATA[\n";
- $cdata_end .= "\n$comment]]>";
- } else {
- $cdata_start = "\n<!-- Hide script\n";
- $cdata_end = $comment;
- $cdata_end .= " End script hiding -->\n";
- }
- my(@satts);
- push(@satts,'src'=>$src) if $src;
- push(@satts,'type'=>$type);
- push(@satts,'charset'=>$charset) if ($src && $charset);
- $code = $cdata_start . $code . $cdata_end if defined $code;
- push(@result,$self->script({@satts},$code || ''));
- }
- @result;
-}
-END_OF_FUNC
-
-#### Method: end_html
-# End an HTML document.
-# Trivial method for completeness. Just returns "</body>"
-####
-'end_html' => <<'END_OF_FUNC',
-sub end_html {
- return "\n</body>\n</html>";
-}
-END_OF_FUNC
-
-
-################################
-# METHODS USED IN BUILDING FORMS
-################################
-
-#### Method: isindex
-# Just prints out the isindex tag.
-# Parameters:
-# $action -> optional URL of script to run
-# Returns:
-# A string containing a <isindex> tag
-'isindex' => <<'END_OF_FUNC',
-sub isindex {
- my($self,@p) = self_or_default(@_);
- my($action,@other) = rearrange([ACTION],@p);
- $action = qq/ action="$action"/ if $action;
- my($other) = @other ? " @other" : '';
- return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
-}
-END_OF_FUNC
-
-
-#### Method: startform
-# This method is DEPRECATED
-# Start a form
-# Parameters:
-# $method -> optional submission method to use (GET or POST)
-# $action -> optional URL of script to run
-# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
-'startform' => <<'END_OF_FUNC',
-sub startform {
- my($self,@p) = self_or_default(@_);
-
- my($method,$action,$enctype,@other) =
- rearrange([METHOD,ACTION,ENCTYPE],@p);
-
- $method = $self->_maybe_escapeHTML(lc($method || 'post'));
- $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
- if (defined $action) {
- $action = $self->_maybe_escapeHTML($action);
- }
- else {
- $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
- }
- $action = qq(action="$action");
- my($other) = @other ? " @other" : '';
- $self->{'.parametersToAdd'}={};
- return qq/<form method="$method" $action enctype="$enctype"$other>/;
-}
-END_OF_FUNC
-
-#### Method: start_form
-# Start a form
-# Parameters:
-# $method -> optional submission method to use (GET or POST)
-# $action -> optional URL of script to run
-# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
-'start_form' => <<'END_OF_FUNC',
-sub start_form {
- my($self,@p) = self_or_default(@_);
-
- my($method,$action,$enctype,@other) =
- rearrange([METHOD,ACTION,ENCTYPE],@p);
-
- $method = $self->_maybe_escapeHTML(lc($method || 'post'));
-
- if( $XHTML ){
- $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART);
- }else{
- $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
- }
-
- if (defined $action) {
- $action = $self->_maybe_escapeHTML($action);
- }
- else {
- $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
- }
- $action = qq(action="$action");
- my($other) = @other ? " @other" : '';
- $self->{'.parametersToAdd'}={};
- return qq/<form method="$method" $action enctype="$enctype"$other>/;
-}
-END_OF_FUNC
-
-#### Method: start_multipart_form
-'start_multipart_form' => <<'END_OF_FUNC',
-sub start_multipart_form {
- my($self,@p) = self_or_default(@_);
- if (defined($p[0]) && substr($p[0],0,1) eq '-') {
- return $self->start_form(-enctype=>&MULTIPART,@p);
- } else {
- my($method,$action,@other) =
- rearrange([METHOD,ACTION],@p);
- return $self->start_form($method,$action,&MULTIPART,@other);
- }
-}
-END_OF_FUNC
-
-
-
-#### Method: end_form
-# End a form
-# Note: This repeated below under the older name.
-'end_form' => <<'END_OF_FUNC',
-sub end_form {
- my($self,@p) = self_or_default(@_);
- if ( $NOSTICKY ) {
- return wantarray ? ("</form>") : "\n</form>";
- } else {
- if (my @fields = $self->get_fields) {
- return wantarray ? ("<div>",@fields,"</div>","</form>")
- : "<div>".(join '',@fields)."</div>\n</form>";
- } else {
- return "</form>";
- }
- }
-}
-END_OF_FUNC
-
-'endform' => <<'END_OF_FUNC',
-sub endform {
- my($self,@p) = self_or_default(@_);
- if ( $NOSTICKY ) {
- return wantarray ? ("</form>") : "\n</form>";
- } else {
- if (my @fields = $self->get_fields) {
- return wantarray ? ("<div>",@fields,"</div>","</form>")
- : "<div>".(join '',@fields)."</div>\n</form>";
- } else {
- return "</form>";
- }
- }
-}
-END_OF_FUNC
-
-#### Method: end_multipart_form
-# end a multipart form
-'end_multipart_form' => <<'END_OF_FUNC',
-sub end_multipart_form {
- &end_form;
-}
-END_OF_FUNC
-
-
-'_textfield' => <<'END_OF_FUNC',
-sub _textfield {
- my($self,$tag,@p) = self_or_default(@_);
- my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
- rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
-
- my $current = $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : '';
- $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ size="$size"/ : '';
- my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
- my($other) = @other ? " @other" : '';
- # this entered at cristy's request to fix problems with file upload fields
- # and WebTV -- not sure it won't break stuff
- my($value) = $current ne '' ? qq(value="$current") : '';
- $tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
- : qq(<input type="$tag" name="$name" $value$s$m$other>);
-}
-END_OF_FUNC
-
-#### Method: textfield
-# Parameters:
-# $name -> Name of the text field
-# $default -> Optional default value of the field if not
-# already defined.
-# $size -> Optional width of field in characaters.
-# $maxlength -> Optional maximum number of characters.
-# Returns:
-# A string containing a <input type="text"> field
-#
-'textfield' => <<'END_OF_FUNC',
-sub textfield {
- my($self,@p) = self_or_default(@_);
- $self->_textfield('text',@p);
-}
-END_OF_FUNC
-
-
-#### Method: filefield
-# Parameters:
-# $name -> Name of the file upload field
-# $size -> Optional width of field in characaters.
-# $maxlength -> Optional maximum number of characters.
-# Returns:
-# A string containing a <input type="file"> field
-#
-'filefield' => <<'END_OF_FUNC',
-sub filefield {
- my($self,@p) = self_or_default(@_);
- $self->_textfield('file',@p);
-}
-END_OF_FUNC
-
-
-#### Method: password
-# Create a "secret password" entry field
-# Parameters:
-# $name -> Name of the field
-# $default -> Optional default value of the field if not
-# already defined.
-# $size -> Optional width of field in characters.
-# $maxlength -> Optional maximum characters that can be entered.
-# Returns:
-# A string containing a <input type="password"> field
-#
-'password_field' => <<'END_OF_FUNC',
-sub password_field {
- my ($self,@p) = self_or_default(@_);
- $self->_textfield('password',@p);
-}
-END_OF_FUNC
-
-#### Method: textarea
-# Parameters:
-# $name -> Name of the text field
-# $default -> Optional default value of the field if not
-# already defined.
-# $rows -> Optional number of rows in text area
-# $columns -> Optional number of columns in text area
-# Returns:
-# A string containing a <textarea></textarea> tag
-#
-'textarea' => <<'END_OF_FUNC',
-sub textarea {
- my($self,@p) = self_or_default(@_);
- my($name,$default,$rows,$cols,$override,$tabindex,@other) =
- rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
-
- my($current)= $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
- $current = defined($current) ? $self->_maybe_escapeHTML($current) : '';
- my($r) = $rows ? qq/ rows="$rows"/ : '';
- my($c) = $cols ? qq/ cols="$cols"/ : '';
- my($other) = @other ? " @other" : '';
- $tabindex = $self->element_tab($tabindex);
- return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
-}
-END_OF_FUNC
-
-
-#### Method: button
-# Create a javascript button.
-# Parameters:
-# $name -> (optional) Name for the button. (-name)
-# $value -> (optional) Value of the button when selected (and visible name) (-value)
-# $onclick -> (optional) Text of the JavaScript to run when the button is
-# clicked.
-# Returns:
-# A string containing a <input type="button"> tag
-####
-'button' => <<'END_OF_FUNC',
-sub button {
- my($self,@p) = self_or_default(@_);
-
- my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
- [ONCLICK,SCRIPT],TABINDEX],@p);
-
- $label=$self->_maybe_escapeHTML($label);
- $value=$self->_maybe_escapeHTML($value,1);
- $script=$self->_maybe_escapeHTML($script);
-
- $script ||= '';
-
- my($name) = '';
- $name = qq/ name="$label"/ if $label;
- $value = $value || $label;
- my($val) = '';
- $val = qq/ value="$value"/ if $value;
- $script = qq/ onclick="$script"/ if $script;
- my($other) = @other ? " @other" : '';
- $tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
- : qq(<input type="button"$name$val$script$other>);
-}
-END_OF_FUNC
-
-
-#### Method: submit
-# Create a "submit query" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# $value -> (optional) Value of the button when selected (also doubles as label).
-# $label -> (optional) Label printed on the button(also doubles as the value).
-# Returns:
-# A string containing a <input type="submit"> tag
-####
-'submit' => <<'END_OF_FUNC',
-sub submit {
- my($self,@p) = self_or_default(@_);
-
- my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
-
- $label=$self->_maybe_escapeHTML($label);
- $value=$self->_maybe_escapeHTML($value,1);
-
- my $name = $NOSTICKY ? '' : 'name=".submit" ';
- $name = qq/name="$label" / if defined($label);
- $value = defined($value) ? $value : $label;
- my $val = '';
- $val = qq/value="$value" / if defined($value);
- $tabindex = $self->element_tab($tabindex);
- my($other) = @other ? "@other " : '';
- return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
- : qq(<input type="submit" $name$val$other>);
-}
-END_OF_FUNC
-
-
-#### Method: reset
-# Create a "reset" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# Returns:
-# A string containing a <input type="reset"> tag
-####
-'reset' => <<'END_OF_FUNC',
-sub reset {
- my($self,@p) = self_or_default(@_);
- my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
- $label=$self->_maybe_escapeHTML($label);
- $value=$self->_maybe_escapeHTML($value,1);
- my ($name) = ' name=".reset"';
- $name = qq/ name="$label"/ if defined($label);
- $value = defined($value) ? $value : $label;
- my($val) = '';
- $val = qq/ value="$value"/ if defined($value);
- my($other) = @other ? " @other" : '';
- $tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
- : qq(<input type="reset"$name$val$other>);
-}
-END_OF_FUNC
-
-
-#### Method: defaults
-# Create a "defaults" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# Returns:
-# A string containing a <input type="submit" name=".defaults"> tag
-#
-# Note: this button has a special meaning to the initialization script,
-# and tells it to ERASE the current query string so that your defaults
-# are used again!
-####
-'defaults' => <<'END_OF_FUNC',
-sub defaults {
- my($self,@p) = self_or_default(@_);
-
- my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
-
- $label=$self->_maybe_escapeHTML($label,1);
- $label = $label || "Defaults";
- my($value) = qq/ value="$label"/;
- my($other) = @other ? " @other" : '';
- $tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
- : qq/<input type="submit" NAME=".defaults"$value$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: comment
-# Create an HTML <!-- comment -->
-# Parameters: a string
-'comment' => <<'END_OF_FUNC',
-sub comment {
- my($self,@p) = self_or_CGI(@_);
- return "<!-- @p -->";
-}
-END_OF_FUNC
-
-#### Method: checkbox
-# Create a checkbox that is not logically linked to any others.
-# The field value is "on" when the button is checked.
-# Parameters:
-# $name -> Name of the checkbox
-# $checked -> (optional) turned on by default if true
-# $value -> (optional) value of the checkbox, 'on' by default
-# $label -> (optional) a user-readable label printed next to the box.
-# Otherwise the checkbox name is used.
-# Returns:
-# A string containing a <input type="checkbox"> field
-####
-'checkbox' => <<'END_OF_FUNC',
-sub checkbox {
- my($self,@p) = self_or_default(@_);
-
- my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
- rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
- [OVERRIDE,FORCE],TABINDEX],@p);
-
- $value = defined $value ? $value : 'on';
-
- if (!$override && ($self->{'.fieldnames'}->{$name} ||
- defined $self->param($name))) {
- $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
- } else {
- $checked = $self->_checked($checked);
- }
- my($the_label) = defined $label ? $label : $name;
- $name = $self->_maybe_escapeHTML($name);
- $value = $self->_maybe_escapeHTML($value,1);
- $the_label = $self->_maybe_escapeHTML($the_label);
- my($other) = @other ? "@other " : '';
- $tabindex = $self->element_tab($tabindex);
- $self->register_parameter($name);
- return $XHTML ? CGI::label($labelattributes,
- qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
- : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
-}
-END_OF_FUNC
-
-
-
-# Escape HTML
-'escapeHTML' => <<'END_OF_FUNC',
-sub escapeHTML {
- # hack to work around earlier hacks
- push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
- my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
- return undef unless defined($toencode);
- $toencode =~ s{&}{&}gso;
- $toencode =~ s{<}{<}gso;
- $toencode =~ s{>}{>}gso;
- if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
- # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
- # <http://validator.w3.org/docs/errors.html#bad-entity> /
- # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
- $toencode =~ s{"}{"}gso;
- }
- else {
- $toencode =~ s{"}{"}gso;
- }
-
- # Handle bug in some browsers with Latin charsets
- if ($self->{'.charset'}
- && (uc($self->{'.charset'}) eq 'ISO-8859-1'
- || uc($self->{'.charset'}) eq 'WINDOWS-1252')) {
- $toencode =~ s{'}{'}gso;
- $toencode =~ s{\x8b}{‹}gso;
- $toencode =~ s{\x9b}{›}gso;
- if (defined $newlinestoo && $newlinestoo) {
- $toencode =~ s{\012}{ }gso;
- $toencode =~ s{\015}{ }gso;
- }
- }
- return $toencode;
-}
-END_OF_FUNC
-
-# unescape HTML -- used internally
-'unescapeHTML' => <<'END_OF_FUNC',
-sub unescapeHTML {
- # hack to work around earlier hacks
- push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
- my ($self,$string) = CGI::self_or_default(@_);
- return undef unless defined($string);
- my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
- : 1;
- # thanks to Randal Schwartz for the correct solution to this one
- $string=~ s[&([^\s&]*?);]{
- local $_ = $1;
- /^amp$/i ? "&" :
- /^quot$/i ? '"' :
- /^gt$/i ? ">" :
- /^lt$/i ? "<" :
- /^#(\d+)$/ && $latin ? chr($1) :
- /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
- "&$_;"
- }gex;
- return $string;
-}
-END_OF_FUNC
-
-# Internal procedure - don't use
-'_tableize' => <<'END_OF_FUNC',
-sub _tableize {
- my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
- my @rowheaders = $rowheaders ? @$rowheaders : ();
- my @colheaders = $colheaders ? @$colheaders : ();
- my($result);
-
- if (defined($columns)) {
- $rows = int(0.99 + @elements/$columns) unless defined($rows);
- }
- if (defined($rows)) {
- $columns = int(0.99 + @elements/$rows) unless defined($columns);
- }
-
- # rearrange into a pretty table
- $result = "<table>";
- my($row,$column);
- unshift(@colheaders,'') if @colheaders && @rowheaders;
- $result .= "<tr>" if @colheaders;
- for (@colheaders) {
- $result .= "<th>$_</th>";
- }
- for ($row=0;$row<$rows;$row++) {
- $result .= "<tr>";
- $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
- for ($column=0;$column<$columns;$column++) {
- $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
- if defined($elements[$column*$rows + $row]);
- }
- $result .= "</tr>";
- }
- $result .= "</table>";
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: radio_group
-# Create a list of logically-linked radio buttons.
-# Parameters:
-# $name -> Common name for all the buttons.
-# $values -> A pointer to a regular array containing the
-# values for each button in the group.
-# $default -> (optional) Value of the button to turn on by default. Pass '-'
-# to turn _nothing_ on.
-# $linebreak -> (optional) Set to true to place linebreaks
-# between the buttons.
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# An ARRAY containing a series of <input type="radio"> fields
-####
-'radio_group' => <<'END_OF_FUNC',
-sub radio_group {
- my($self,@p) = self_or_default(@_);
- $self->_box_group('radio',@p);
-}
-END_OF_FUNC
-
-#### Method: checkbox_group
-# Create a list of logically-linked checkboxes.
-# Parameters:
-# $name -> Common name for all the check boxes
-# $values -> A pointer to a regular array containing the
-# values for each checkbox in the group.
-# $defaults -> (optional)
-# 1. If a pointer to a regular array of checkbox values,
-# then this will be used to decide which
-# checkboxes to turn on by default.
-# 2. If a scalar, will be assumed to hold the
-# value of a single checkbox in the group to turn on.
-# $linebreak -> (optional) Set to true to place linebreaks
-# between the buttons.
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# An ARRAY containing a series of <input type="checkbox"> fields
-####
-
-'checkbox_group' => <<'END_OF_FUNC',
-sub checkbox_group {
- my($self,@p) = self_or_default(@_);
- $self->_box_group('checkbox',@p);
-}
-END_OF_FUNC
-
-'_box_group' => <<'END_OF_FUNC',
-sub _box_group {
- my $self = shift;
- my $box_type = shift;
-
- my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
- $attributes,$rows,$columns,$rowheaders,$colheaders,
- $override,$nolabels,$tabindex,$disabled,@other) =
- rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
- ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
- [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
- ],@_);
-
-
- my($result,$checked,@elements,@values);
-
- @values = $self->_set_values_and_labels($values,\$labels,$name);
- my %checked = $self->previous_or_default($name,$defaults,$override);
-
- # If no check array is specified, check the first by default
- $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
-
- $name=$self->_maybe_escapeHTML($name);
-
- my %tabs = ();
- if ($TABINDEX && $tabindex) {
- if (!ref $tabindex) {
- $self->element_tab($tabindex);
- } elsif (ref $tabindex eq 'ARRAY') {
- %tabs = map {$_=>$self->element_tab} @$tabindex;
- } elsif (ref $tabindex eq 'HASH') {
- %tabs = %$tabindex;
- }
- }
- %tabs = map {$_=>$self->element_tab} @values unless %tabs;
- my $other = @other ? "@other " : '';
- my $radio_checked;
-
- # for disabling groups of radio/checkbox buttons
- my %disabled;
- for (@{$disabled}) {
- $disabled{$_}=1;
- }
-
- for (@values) {
- my $disable="";
- if ($disabled{$_}) {
- $disable="disabled='1'";
- }
-
- my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
- : $checked{$_});
- my($break);
- if ($linebreak) {
- $break = $XHTML ? "<br />" : "<br>";
- }
- else {
- $break = '';
- }
- my($label)='';
- unless (defined($nolabels) && $nolabels) {
- $label = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label = $self->_maybe_escapeHTML($label,1);
- $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
- }
- my $attribs = $self->_set_attributes($_, $attributes);
- my $tab = $tabs{$_};
- $_=$self->_maybe_escapeHTML($_);
-
- if ($XHTML) {
- push @elements,
- CGI::label($labelattributes,
- qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
- } else {
- push(@elements,qq/<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable>${label}${break}/);
- }
- }
- $self->register_parameter($name);
- return wantarray ? @elements : "@elements"
- unless defined($columns) || defined($rows);
- return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
-}
-END_OF_FUNC
-
-
-#### Method: popup_menu
-# Create a popup menu.
-# Parameters:
-# $name -> Name for all the menu
-# $values -> A pointer to a regular array containing the
-# text of each menu item.
-# $default -> (optional) Default item to display
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# A string containing the definition of a popup menu.
-####
-'popup_menu' => <<'END_OF_FUNC',
-sub popup_menu {
- my($self,@p) = self_or_default(@_);
-
- my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
- rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
- ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
- my($result,%selected);
-
- if (!$override && defined($self->param($name))) {
- $selected{$self->param($name)}++;
- } elsif (defined $default) {
- %selected = map {$_=>1} ref($default) eq 'ARRAY'
- ? @$default
- : $default;
- }
- $name=$self->_maybe_escapeHTML($name);
- my($other) = @other ? " @other" : '';
-
- my(@values);
- @values = $self->_set_values_and_labels($values,\$labels,$name);
- $tabindex = $self->element_tab($tabindex);
- $name = q{} if ! defined $name;
- $result = qq/<select name="$name" $tabindex$other>\n/;
- for (@values) {
- if (/<optgroup/) {
- for my $v (split(/\n/)) {
- my $selectit = $XHTML ? 'selected="selected"' : 'selected';
- for my $selected (keys %selected) {
- $v =~ s/(value="\Q$selected\E")/$selectit $1/;
- }
- $result .= "$v\n";
- }
- }
- else {
- my $attribs = $self->_set_attributes($_, $attributes);
- my($selectit) = $self->_selected($selected{$_});
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->_maybe_escapeHTML($_);
- $label = $self->_maybe_escapeHTML($label,1);
- $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
- }
- }
-
- $result .= "</select>";
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: optgroup
-# Create a optgroup.
-# Parameters:
-# $name -> Label for the group
-# $values -> A pointer to a regular array containing the
-# values for each option line in the group.
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each item
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# $labeled -> (optional)
-# A true value indicates the value should be used as the label attribute
-# in the option elements.
-# The label attribute specifies the option label presented to the user.
-# This defaults to the content of the <option> element, but the label
-# attribute allows authors to more easily use optgroup without sacrificing
-# compatibility with browsers that do not support option groups.
-# $novals -> (optional)
-# A true value indicates to suppress the val attribute in the option elements
-# Returns:
-# A string containing the definition of an option group.
-####
-'optgroup' => <<'END_OF_FUNC',
-sub optgroup {
- my($self,@p) = self_or_default(@_);
- my($name,$values,$attributes,$labeled,$noval,$labels,@other)
- = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
-
- my($result,@values);
- @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
- my($other) = @other ? " @other" : '';
-
- $name = $self->_maybe_escapeHTML($name) || q{};
- $result = qq/<optgroup label="$name"$other>\n/;
- for (@values) {
- if (/<optgroup/) {
- for (split(/\n/)) {
- my $selectit = $XHTML ? 'selected="selected"' : 'selected';
- s/(value="$selected")/$selectit $1/ if defined $selected;
- $result .= "$_\n";
- }
- }
- else {
- my $attribs = $self->_set_attributes($_, $attributes);
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label=$self->_maybe_escapeHTML($label);
- my($value)=$self->_maybe_escapeHTML($_,1);
- $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
- : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
- : $novals ? "<option$attribs>$label</option>\n"
- : "<option$attribs value=\"$value\">$label</option>\n";
- }
- }
- $result .= "</optgroup>";
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: scrolling_list
-# Create a scrolling list.
-# Parameters:
-# $name -> name for the list
-# $values -> A pointer to a regular array containing the
-# values for each option line in the list.
-# $defaults -> (optional)
-# 1. If a pointer to a regular array of options,
-# then this will be used to decide which
-# lines to turn on by default.
-# 2. Otherwise holds the value of the single line to turn on.
-# $size -> (optional) Size of the list.
-# $multiple -> (optional) If set, allow multiple selections.
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# A string containing the definition of a scrolling list.
-####
-'scrolling_list' => <<'END_OF_FUNC',
-sub scrolling_list {
- my($self,@p) = self_or_default(@_);
- my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
- = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
- SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
-
- my($result,@values);
- @values = $self->_set_values_and_labels($values,\$labels,$name);
-
- $size = $size || scalar(@values);
-
- my(%selected) = $self->previous_or_default($name,$defaults,$override);
-
- my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
- my($has_size) = $size ? qq/ size="$size"/: '';
- my($other) = @other ? " @other" : '';
-
- $name=$self->_maybe_escapeHTML($name);
- $tabindex = $self->element_tab($tabindex);
- $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
- for (@values) {
- if (/<optgroup/) {
- for my $v (split(/\n/)) {
- my $selectit = $XHTML ? 'selected="selected"' : 'selected';
- for my $selected (keys %selected) {
- $v =~ s/(value="$selected")/$selectit $1/;
- }
- $result .= "$v\n";
- }
- }
- else {
- my $attribs = $self->_set_attributes($_, $attributes);
- my($selectit) = $self->_selected($selected{$_});
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->_maybe_escapeHTML($_);
- $label = $self->_maybe_escapeHTML($label,1);
- $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
- }
- }
-
- $result .= "</select>";
- $self->register_parameter($name);
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: hidden
-# Parameters:
-# $name -> Name of the hidden field
-# @default -> (optional) Initial values of field (may be an array)
-# or
-# $default->[initial values of field]
-# Returns:
-# A string containing a <input type="hidden" name="name" value="value">
-####
-'hidden' => <<'END_OF_FUNC',
-sub hidden {
- my($self,@p) = self_or_default(@_);
-
- # this is the one place where we departed from our standard
- # calling scheme, so we have to special-case (darn)
- my(@result,@value);
- my($name,$default,$override,@other) =
- rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
-
- my $do_override = 0;
- if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
- @value = ref($default) ? @{$default} : $default;
- $do_override = $override;
- } else {
- for ($default,$override,@other) {
- push(@value,$_) if defined($_);
- }
- undef @other;
- }
-
- # use previous values if override is not set
- my @prev = $self->param($name);
- @value = @prev if !$do_override && @prev;
-
- $name=$self->_maybe_escapeHTML($name);
- for (@value) {
- $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : '';
- push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
- : qq(<input type="hidden" name="$name" value="$_" @other>);
- }
- return wantarray ? @result : join('',@result);
-}
-END_OF_FUNC
-
-
-#### Method: image_button
-# Parameters:
-# $name -> Name of the button
-# $src -> URL of the image source
-# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
-# Returns:
-# A string containing a <input type="image" name="name" src="url" align="alignment">
-####
-'image_button' => <<'END_OF_FUNC',
-sub image_button {
- my($self,@p) = self_or_default(@_);
-
- my($name,$src,$alignment,@other) =
- rearrange([NAME,SRC,ALIGN],@p);
-
- my($align) = $alignment ? " align=\L\"$alignment\"" : '';
- my($other) = @other ? " @other" : '';
- $name=$self->_maybe_escapeHTML($name);
- return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
- : qq/<input type="image" name="$name" src="$src"$align$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: self_url
-# Returns a URL containing the current script and all its
-# param/value pairs arranged as a query. You can use this
-# to create a link that, when selected, will reinvoke the
-# script with all its state information preserved.
-####
-'self_url' => <<'END_OF_FUNC',
-sub self_url {
- my($self,@p) = self_or_default(@_);
- return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
-}
-END_OF_FUNC
-
-
-# This is provided as a synonym to self_url() for people unfortunate
-# enough to have incorporated it into their programs already!
-'state' => <<'END_OF_FUNC',
-sub state {
- &self_url;
-}
-END_OF_FUNC
-
-
-#### Method: url
-# Like self_url, but doesn't return the query string part of
-# the URL.
-####
-'url' => <<'END_OF_FUNC',
-sub url {
- my($self,@p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
- rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
- my $url = '';
- $full++ if $base || !($relative || $absolute);
- $rewrite++ unless defined $rewrite;
-
- my $path = $self->path_info;
- my $script_name = $self->script_name;
- my $request_uri = unescape($self->request_uri) || '';
- my $query_str = $self->query_string;
-
- my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
-
- my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
- $uri =~ s/\?.*$//s; # remove query string
- $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
-# $uri =~ s/\Q$path\E$// if defined $path; # remove path
-
- if ($full) {
- my $protocol = $self->protocol();
- $url = "$protocol://";
- my $vh = http('x_forwarded_host') || http('host') || '';
- $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
-
- $url .= $vh || server_name();
-
- my $port = $self->virtual_port;
-
- # add the port to the url unless it's the protocol's default port
- $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80)
- or (lc($protocol) eq 'https' && $port == 443);
-
- return $url if $base;
-
- $url .= $uri;
- } elsif ($relative) {
- ($url) = $uri =~ m!([^/]+)$!;
- } elsif ($absolute) {
- $url = $uri;
- }
-
- $url .= $path if $path_info and defined $path;
- $url .= "?$query_str" if $query and $query_str ne '';
- $url ||= '';
- $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
- return $url;
-}
-
-END_OF_FUNC
-
-#### Method: cookie
-# Set or read a cookie from the specified name.
-# Cookie can then be passed to header().
-# Usual rules apply to the stickiness of -value.
-# Parameters:
-# -name -> name for this cookie (optional)
-# -value -> value of this cookie (scalar, array or hash)
-# -path -> paths for which this cookie is valid (optional)
-# -domain -> internet domain in which this cookie is valid (optional)
-# -secure -> if true, cookie only passed through secure channel (optional)
-# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
-####
-'cookie' => <<'END_OF_FUNC',
-sub cookie {
- my($self,@p) = self_or_default(@_);
- my($name,$value,$path,$domain,$secure,$expires,$httponly) =
- rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
-
- require CGI::Cookie;
-
- # if no value is supplied, then we retrieve the
- # value of the cookie, if any. For efficiency, we cache the parsed
- # cookies in our state variables.
- unless ( defined($value) ) {
- $self->{'.cookies'} = CGI::Cookie->fetch;
-
- # If no name is supplied, then retrieve the names of all our cookies.
- return () unless $self->{'.cookies'};
- return keys %{$self->{'.cookies'}} unless $name;
- return () unless $self->{'.cookies'}->{$name};
- return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
- }
-
- # If we get here, we're creating a new cookie
- return undef unless defined($name) && $name ne ''; # this is an error
-
- my @param;
- push(@param,'-name'=>$name);
- push(@param,'-value'=>$value);
- push(@param,'-domain'=>$domain) if $domain;
- push(@param,'-path'=>$path) if $path;
- push(@param,'-expires'=>$expires) if $expires;
- push(@param,'-secure'=>$secure) if $secure;
- push(@param,'-httponly'=>$httponly) if $httponly;
-
- return CGI::Cookie->new(@param);
-}
-END_OF_FUNC
-
-'parse_keywordlist' => <<'END_OF_FUNC',
-sub parse_keywordlist {
- my($self,$tosplit) = @_;
- $tosplit = unescape($tosplit); # unescape the keywords
- $tosplit=~tr/+/ /; # pluses to spaces
- my(@keywords) = split(/\s+/,$tosplit);
- return @keywords;
-}
-END_OF_FUNC
-
-'param_fetch' => <<'END_OF_FUNC',
-sub param_fetch {
- my($self,@p) = self_or_default(@_);
- my($name) = rearrange([NAME],@p);
- return [] unless defined $name;
-
- unless (exists($self->{param}{$name})) {
- $self->add_parameter($name);
- $self->{param}{$name} = [];
- }
-
- return $self->{param}{$name};
-}
-END_OF_FUNC
-
-###############################################
-# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
-###############################################
-
-#### Method: path_info
-# Return the extra virtual path information provided
-# after the URL (if any)
-####
-'path_info' => <<'END_OF_FUNC',
-sub path_info {
- my ($self,$info) = self_or_default(@_);
- if (defined($info)) {
- $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
- $self->{'.path_info'} = $info;
- } elsif (! defined($self->{'.path_info'}) ) {
- my (undef,$path_info) = $self->_name_and_path_from_env;
- $self->{'.path_info'} = $path_info || '';
- }
- return $self->{'.path_info'};
-}
-END_OF_FUNC
-
-# This function returns a potentially modified version of SCRIPT_NAME
-# and PATH_INFO. Some HTTP servers do sanitise the paths in those
-# variables. It is the case of at least Apache 2. If for instance the
-# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
-# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
-# SCRIPT_NAME=/path/to/env.cgi
-# PATH_INFO=/x/y/x
-#
-# This is all fine except that some bogus CGI scripts expect
-# PATH_INFO=/http://foo when the user requests
-# http://xxx/script.cgi/http://foo
-#
-# Old versions of this module used to accomodate with those scripts, so
-# this is why we do this here to keep those scripts backward compatible.
-# Basically, we accomodate with those scripts but within limits, that is
-# we only try to preserve the number of / that were provided by the user
-# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
-# of consecutive /.
-#
-# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
-# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
-# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
-# possibly sanitised by the HTTP server, so in the case of Apache 2:
-# script_name == /foo/x/z/script.cgi and path_info == /b/c.
-#
-# Future versions of this module may no longer do that, so one should
-# avoid relying on the browser, proxy, server, and CGI.pm preserving the
-# number of consecutive slashes as no guarantee can be made there.
-'_name_and_path_from_env' => <<'END_OF_FUNC',
-sub _name_and_path_from_env {
- my $self = shift;
- my $script_name = $ENV{SCRIPT_NAME} || '';
- my $path_info = $ENV{PATH_INFO} || '';
- my $uri = $self->request_uri || '';
-
- $uri =~ s/\?.*//s;
- $uri = unescape($uri);
-
- if ($uri ne "$script_name$path_info") {
- my $script_name_pattern = quotemeta($script_name);
- my $path_info_pattern = quotemeta($path_info);
- $script_name_pattern =~ s{(?:\\/)+}{/+}g;
- $path_info_pattern =~ s{(?:\\/)+}{/+}g;
-
- if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
- # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
- # numer of consecutive slashes, so we can extract the info from
- # REQUEST_URI:
- ($script_name, $path_info) = ($1, $2);
- }
- }
- return ($script_name,$path_info);
-}
-END_OF_FUNC
-
-
-#### Method: request_method
-# Returns 'POST', 'GET', 'PUT' or 'HEAD'
-####
-'request_method' => <<'END_OF_FUNC',
-sub request_method {
- return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef;
-}
-END_OF_FUNC
-
-#### Method: content_type
-# Returns the content_type string
-####
-'content_type' => <<'END_OF_FUNC',
-sub content_type {
- return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef;
-}
-END_OF_FUNC
-
-#### Method: path_translated
-# Return the physical path information provided
-# by the URL (if any)
-####
-'path_translated' => <<'END_OF_FUNC',
-sub path_translated {
- return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef;
-}
-END_OF_FUNC
-
-
-#### Method: request_uri
-# Return the literal request URI
-####
-'request_uri' => <<'END_OF_FUNC',
-sub request_uri {
- return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef;
-}
-END_OF_FUNC
-
-
-#### Method: query_string
-# Synthesize a query string from our current
-# parameters
-####
-'query_string' => <<'END_OF_FUNC',
-sub query_string {
- my($self) = self_or_default(@_);
- my($param,$value,@pairs);
- for $param ($self->param) {
- my($eparam) = escape($param);
- for $value ($self->param($param)) {
- $value = escape($value);
- next unless defined $value;
- push(@pairs,"$eparam=$value");
- }
- }
- for (keys %{$self->{'.fieldnames'}}) {
- push(@pairs,".cgifields=".escape("$_"));
- }
- return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
-}
-END_OF_FUNC
-
-
-#### Method: accept
-# Without parameters, returns an array of the
-# MIME types the browser accepts.
-# With a single parameter equal to a MIME
-# type, will return undef if the browser won't
-# accept it, 1 if the browser accepts it but
-# doesn't give a preference, or a floating point
-# value between 0.0 and 1.0 if the browser
-# declares a quantitative score for it.
-# This handles MIME type globs correctly.
-####
-'Accept' => <<'END_OF_FUNC',
-sub Accept {
- my($self,$search) = self_or_CGI(@_);
- my(%prefs,$type,$pref,$pat);
-
- my(@accept) = defined $self->http('accept')
- ? split(',',$self->http('accept'))
- : ();
-
- for (@accept) {
- ($pref) = /q=(\d\.\d+|\d+)/;
- ($type) = m#(\S+/[^;]+)#;
- next unless $type;
- $prefs{$type}=$pref || 1;
- }
-
- return keys %prefs unless $search;
-
- # if a search type is provided, we may need to
- # perform a pattern matching operation.
- # The MIME types use a glob mechanism, which
- # is easily translated into a perl pattern match
-
- # First return the preference for directly supported
- # types:
- return $prefs{$search} if $prefs{$search};
-
- # Didn't get it, so try pattern matching.
- for (keys %prefs) {
- next unless /\*/; # not a pattern match
- ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
- $pat =~ s/\*/.*/g; # turn it into a pattern
- return $prefs{$_} if $search=~/$pat/;
- }
-}
-END_OF_FUNC
-
-
-#### Method: user_agent
-# If called with no parameters, returns the user agent.
-# If called with one parameter, does a pattern match (case
-# insensitive) on the user agent.
-####
-'user_agent' => <<'END_OF_FUNC',
-sub user_agent {
- my($self,$match)=self_or_CGI(@_);
- my $user_agent = $self->http('user_agent');
- return $user_agent unless defined $match && $match && $user_agent;
- return $user_agent =~ /$match/i;
-}
-END_OF_FUNC
-
-
-#### Method: raw_cookie
-# Returns the magic cookies for the session.
-# The cookies are not parsed or altered in any way, i.e.
-# cookies are returned exactly as given in the HTTP
-# headers. If a cookie name is given, only that cookie's
-# value is returned, otherwise the entire raw cookie
-# is returned.
-####
-'raw_cookie' => <<'END_OF_FUNC',
-sub raw_cookie {
- my($self,$key) = self_or_CGI(@_);
-
- require CGI::Cookie;
-
- if (defined($key)) {
- $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
- unless $self->{'.raw_cookies'};
-
- return () unless $self->{'.raw_cookies'};
- return () unless $self->{'.raw_cookies'}->{$key};
- return $self->{'.raw_cookies'}->{$key};
- }
- return $self->http('cookie') || $ENV{'COOKIE'} || '';
-}
-END_OF_FUNC
-
-#### Method: virtual_host
-# Return the name of the virtual_host, which
-# is not always the same as the server
-######
-'virtual_host' => <<'END_OF_FUNC',
-sub virtual_host {
- my $vh = http('x_forwarded_host') || http('host') || server_name();
- $vh =~ s/:\d+$//; # get rid of port number
- return $vh;
-}
-END_OF_FUNC
-
-#### Method: remote_host
-# Return the name of the remote host, or its IP
-# address if unavailable. If this variable isn't
-# defined, it returns "localhost" for debugging
-# purposes.
-####
-'remote_host' => <<'END_OF_FUNC',
-sub remote_host {
- return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
- || 'localhost';
-}
-END_OF_FUNC
-
-
-#### Method: remote_addr
-# Return the IP addr of the remote host.
-####
-'remote_addr' => <<'END_OF_FUNC',
-sub remote_addr {
- return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
-}
-END_OF_FUNC
-
-
-#### Method: script_name
-# Return the partial URL to this script for
-# self-referencing scripts. Also see
-# self_url(), which returns a URL with all state information
-# preserved.
-####
-'script_name' => <<'END_OF_FUNC',
-sub script_name {
- my ($self,@p) = self_or_default(@_);
- if (@p) {
- $self->{'.script_name'} = shift @p;
- } elsif (!exists $self->{'.script_name'}) {
- my ($script_name,$path_info) = $self->_name_and_path_from_env();
- $self->{'.script_name'} = $script_name;
- }
- return $self->{'.script_name'};
-}
-END_OF_FUNC
-
-
-#### Method: referer
-# Return the HTTP_REFERER: useful for generating
-# a GO BACK button.
-####
-'referer' => <<'END_OF_FUNC',
-sub referer {
- my($self) = self_or_CGI(@_);
- return $self->http('referer');
-}
-END_OF_FUNC
-
-
-#### Method: server_name
-# Return the name of the server
-####
-'server_name' => <<'END_OF_FUNC',
-sub server_name {
- return $ENV{'SERVER_NAME'} || 'localhost';
-}
-END_OF_FUNC
-
-#### Method: server_software
-# Return the name of the server software
-####
-'server_software' => <<'END_OF_FUNC',
-sub server_software {
- return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
-}
-END_OF_FUNC
-
-#### Method: virtual_port
-# Return the server port, taking virtual hosts into account
-####
-'virtual_port' => <<'END_OF_FUNC',
-sub virtual_port {
- my($self) = self_or_default(@_);
- my $vh = $self->http('x_forwarded_host') || $self->http('host');
- my $protocol = $self->protocol;
- if ($vh) {
- return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
- } else {
- return $self->server_port();
- }
-}
-END_OF_FUNC
-
-#### Method: server_port
-# Return the tcp/ip port the server is running on
-####
-'server_port' => <<'END_OF_FUNC',
-sub server_port {
- return $ENV{'SERVER_PORT'} || 80; # for debugging
-}
-END_OF_FUNC
-
-#### Method: server_protocol
-# Return the protocol (usually HTTP/1.0)
-####
-'server_protocol' => <<'END_OF_FUNC',
-sub server_protocol {
- return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
-}
-END_OF_FUNC
-
-#### Method: http
-# Return the value of an HTTP variable, or
-# the list of variables if none provided
-####
-'http' => <<'END_OF_FUNC',
-sub http {
- my ($self,$parameter) = self_or_CGI(@_);
- if ( defined($parameter) ) {
- $parameter =~ tr/-a-z/_A-Z/;
- if ( $parameter =~ /^HTTP(?:_|$)/ ) {
- return $ENV{$parameter};
- }
- return $ENV{"HTTP_$parameter"};
- }
- return grep { /^HTTP(?:_|$)/ } keys %ENV;
-}
-END_OF_FUNC
-
-#### Method: https
-# Return the value of HTTPS, or
-# the value of an HTTPS variable, or
-# the list of variables
-####
-'https' => <<'END_OF_FUNC',
-sub https {
- my ($self,$parameter) = self_or_CGI(@_);
- if ( defined($parameter) ) {
- $parameter =~ tr/-a-z/_A-Z/;
- if ( $parameter =~ /^HTTPS(?:_|$)/ ) {
- return $ENV{$parameter};
- }
- return $ENV{"HTTPS_$parameter"};
- }
- return wantarray
- ? grep { /^HTTPS(?:_|$)/ } keys %ENV
- : $ENV{'HTTPS'};
-}
-END_OF_FUNC
-
-#### Method: protocol
-# Return the protocol (http or https currently)
-####
-'protocol' => <<'END_OF_FUNC',
-sub protocol {
- local($^W)=0;
- my $self = shift;
- return 'https' if uc($self->https()) eq 'ON';
- return 'https' if $self->server_port == 443;
- my $prot = $self->server_protocol;
- my($protocol,$version) = split('/',$prot);
- return "\L$protocol\E";
-}
-END_OF_FUNC
-
-#### Method: remote_ident
-# Return the identity of the remote user
-# (but only if his host is running identd)
-####
-'remote_ident' => <<'END_OF_FUNC',
-sub remote_ident {
- return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef;
-}
-END_OF_FUNC
-
-
-#### Method: auth_type
-# Return the type of use verification/authorization in use, if any.
-####
-'auth_type' => <<'END_OF_FUNC',
-sub auth_type {
- return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef;
-}
-END_OF_FUNC
-
-
-#### Method: remote_user
-# Return the authorization name used for user
-# verification.
-####
-'remote_user' => <<'END_OF_FUNC',
-sub remote_user {
- return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef;
-}
-END_OF_FUNC
-
-
-#### Method: user_name
-# Try to return the remote user's name by hook or by
-# crook
-####
-'user_name' => <<'END_OF_FUNC',
-sub user_name {
- my ($self) = self_or_CGI(@_);
- return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
-}
-END_OF_FUNC
-
-#### Method: nosticky
-# Set or return the NOSTICKY global flag
-####
-'nosticky' => <<'END_OF_FUNC',
-sub nosticky {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::NOSTICKY = $param if defined($param);
- return $CGI::NOSTICKY;
-}
-END_OF_FUNC
-
-#### Method: nph
-# Set or return the NPH global flag
-####
-'nph' => <<'END_OF_FUNC',
-sub nph {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::NPH = $param if defined($param);
- return $CGI::NPH;
-}
-END_OF_FUNC
-
-#### Method: private_tempfiles
-# Set or return the private_tempfiles global flag
-####
-'private_tempfiles' => <<'END_OF_FUNC',
-sub private_tempfiles {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::PRIVATE_TEMPFILES = $param if defined($param);
- return $CGI::PRIVATE_TEMPFILES;
-}
-END_OF_FUNC
-#### Method: close_upload_files
-# Set or return the close_upload_files global flag
-####
-'close_upload_files' => <<'END_OF_FUNC',
-sub close_upload_files {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
- return $CGI::CLOSE_UPLOAD_FILES;
-}
-END_OF_FUNC
-
-
-#### Method: default_dtd
-# Set or return the default_dtd global
-####
-'default_dtd' => <<'END_OF_FUNC',
-sub default_dtd {
- my ($self,$param,$param2) = self_or_CGI(@_);
- if (defined $param2 && defined $param) {
- $CGI::DEFAULT_DTD = [ $param, $param2 ];
- } elsif (defined $param) {
- $CGI::DEFAULT_DTD = $param;
- }
- return $CGI::DEFAULT_DTD;
-}
-END_OF_FUNC
-
-# -------------- really private subroutines -----------------
-'_maybe_escapeHTML' => <<'END_OF_FUNC',
-sub _maybe_escapeHTML {
- # hack to work around earlier hacks
- push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
- my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
- return undef unless defined($toencode);
- return $toencode if ref($self) && !$self->{'escape'};
- return $self->escapeHTML($toencode, $newlinestoo);
-}
-END_OF_FUNC
-
-'previous_or_default' => <<'END_OF_FUNC',
-sub previous_or_default {
- my($self,$name,$defaults,$override) = @_;
- my(%selected);
-
- if (!$override && ($self->{'.fieldnames'}->{$name} ||
- defined($self->param($name)) ) ) {
- $selected{$_}++ for $self->param($name);
- } elsif (defined($defaults) && ref($defaults) &&
- (ref($defaults) eq 'ARRAY')) {
- $selected{$_}++ for @{$defaults};
- } else {
- $selected{$defaults}++ if defined($defaults);
- }
-
- return %selected;
-}
-END_OF_FUNC
-
-'register_parameter' => <<'END_OF_FUNC',
-sub register_parameter {
- my($self,$param) = @_;
- $self->{'.parametersToAdd'}->{$param}++;
-}
-END_OF_FUNC
-
-'get_fields' => <<'END_OF_FUNC',
-sub get_fields {
- my($self) = @_;
- return $self->CGI::hidden('-name'=>'.cgifields',
- '-values'=>[keys %{$self->{'.parametersToAdd'}}],
- '-override'=>1);
-}
-END_OF_FUNC
-
-'read_from_cmdline' => <<'END_OF_FUNC',
-sub read_from_cmdline {
- my($input,@words);
- my($query_string);
- my($subpath);
- if ($DEBUG && @ARGV) {
- @words = @ARGV;
- } elsif ($DEBUG > 1) {
- require Text::ParseWords;
- print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
- chomp(@lines = <STDIN>); # remove newlines
- $input = join(" ",@lines);
- @words = &Text::ParseWords::old_shellwords($input);
- }
- for (@words) {
- s/\\=/%3D/g;
- s/\\&/%26/g;
- }
-
- if ("@words"=~/=/) {
- $query_string = join('&',@words);
- } else {
- $query_string = join('+',@words);
- }
- if ($query_string =~ /^(.*?)\?(.*)$/)
- {
- $query_string = $2;
- $subpath = $1;
- }
- return { 'query_string' => $query_string, 'subpath' => $subpath };
-}
-END_OF_FUNC
-
-#####
-# subroutine: read_multipart
-#
-# Read multipart data and store it into our parameters.
-# An interesting feature is that if any of the parts is a file, we
-# create a temporary file and open up a filehandle on it so that the
-# caller can read from it if necessary.
-#####
-'read_multipart' => <<'END_OF_FUNC',
-sub read_multipart {
- my($self,$boundary,$length) = @_;
- my($buffer) = $self->new_MultipartBuffer($boundary,$length);
- return unless $buffer;
- my(%header,$body);
- my $filenumber = 0;
- while (!$buffer->eof) {
- %header = $buffer->readHeader;
-
- unless (%header) {
- $self->cgi_error("400 Bad request (malformed multipart POST)");
- return;
- }
-
- $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
-
- my($param)= $header{'Content-Disposition'}=~/[\s;]name="([^"]*)"/;
- $param .= $TAINTED;
-
- # See RFC 1867, 2183, 2045
- # NB: File content will be loaded into memory should
- # content-disposition parsing fail.
- my ($filename) = $header{'Content-Disposition'}
- =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
-
- $filename ||= ''; # quench uninit variable warning
-
- $filename =~ s/^"([^"]*)"$/$1/;
- # Test for Opera's multiple upload feature
- my($multipart) = ( defined( $header{'Content-Type'} ) &&
- $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
- 1 : 0;
-
- # add this parameter to our list
- $self->add_parameter($param);
-
- # If no filename specified, then just read the data and assign it
- # to our parameter list.
- if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
- my($value) = $buffer->readBody;
- $value .= $TAINTED;
- push(@{$self->{param}{$param}},$value);
- next;
- }
-
- my ($tmpfile,$tmp,$filehandle);
- UPLOADS: {
- # If we get here, then we are dealing with a potentially large
- # uploaded form. Save the data to a temporary file, then open
- # the file for reading.
-
- # skip the file if uploads disabled
- if ($DISABLE_UPLOADS) {
- while (defined($data = $buffer->read)) { }
- last UPLOADS;
- }
-
- # set the filename to some recognizable value
- if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
- $filename = "multipart/mixed";
- }
-
- # choose a relatively unpredictable tmpfile sequence number
- my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
- for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = CGITempFile->new($seqno);
- $tmp = $tmpfile->as_string;
- last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
- $seqno += int rand(100);
- }
- die "CGI.pm open of tmpfile $tmp/$filename failed: $!\n" unless defined $filehandle;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
- && defined fileno($filehandle);
-
- # if this is an multipart/mixed attachment, save the header
- # together with the body for later parsing with an external
- # MIME parser module
- if ( $multipart ) {
- for ( keys %header ) {
- print $filehandle "$_: $header{$_}${CRLF}";
- }
- print $filehandle "${CRLF}";
- }
-
- my ($data);
- local($\) = '';
- my $totalbytes = 0;
- while (defined($data = $buffer->read)) {
- if (defined $self->{'.upload_hook'})
- {
- $totalbytes += length($data);
- &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
- }
- print $filehandle $data if ($self->{'use_tempfile'});
- }
-
- # back up to beginning of file
- seek($filehandle,0,0);
-
- ## Close the filehandle if requested this allows a multipart MIME
- ## upload to contain many files, and we won't die due to too many
- ## open file handles. The user can access the files using the hash
- ## below.
- close $filehandle if $CLOSE_UPLOAD_FILES;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
-
- # Save some information about the uploaded file where we can get
- # at it later.
- # Use the typeglob as the key, as this is guaranteed to be
- # unique for each filehandle. Don't use the file descriptor as
- # this will be re-used for each filehandle if the
- # close_upload_files feature is used.
- $self->{'.tmpfiles'}->{$$filehandle}= {
- hndl => $filehandle,
- name => $tmpfile,
- info => {%header},
- };
- push(@{$self->{param}{$param}},$filehandle);
- }
- }
-}
-END_OF_FUNC
-
-#####
-# subroutine: read_multipart_related
-#
-# Read multipart/related data and store it into our parameters. The
-# first parameter sets the start of the data. The part identified by
-# this Content-ID will not be stored as a file upload, but will be
-# returned by this method. All other parts will be available as file
-# uploads accessible by their Content-ID
-#####
-'read_multipart_related' => <<'END_OF_FUNC',
-sub read_multipart_related {
- my($self,$start,$boundary,$length) = @_;
- my($buffer) = $self->new_MultipartBuffer($boundary,$length);
- return unless $buffer;
- my(%header,$body);
- my $filenumber = 0;
- my $returnvalue;
- while (!$buffer->eof) {
- %header = $buffer->readHeader;
-
- unless (%header) {
- $self->cgi_error("400 Bad request (malformed multipart POST)");
- return;
- }
-
- my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
- $param .= $TAINTED;
-
- # If this is the start part, then just read the data and assign it
- # to our return variable.
- if ( $param eq $start ) {
- $returnvalue = $buffer->readBody;
- $returnvalue .= $TAINTED;
- next;
- }
-
- # add this parameter to our list
- $self->add_parameter($param);
-
- my ($tmpfile,$tmp,$filehandle);
- UPLOADS: {
- # If we get here, then we are dealing with a potentially large
- # uploaded form. Save the data to a temporary file, then open
- # the file for reading.
-
- # skip the file if uploads disabled
- if ($DISABLE_UPLOADS) {
- while (defined($data = $buffer->read)) { }
- last UPLOADS;
- }
-
- # choose a relatively unpredictable tmpfile sequence number
- my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
- for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = CGITempFile->new($seqno);
- $tmp = $tmpfile->as_string;
- last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
- $seqno += int rand(100);
- }
- die "CGI open of tmpfile: $!\n" unless defined $filehandle;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
- && defined fileno($filehandle);
-
- my ($data);
- local($\) = '';
- my $totalbytes;
- while (defined($data = $buffer->read)) {
- if (defined $self->{'.upload_hook'})
- {
- $totalbytes += length($data);
- &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
- }
- print $filehandle $data if ($self->{'use_tempfile'});
- }
-
- # back up to beginning of file
- seek($filehandle,0,0);
-
- ## Close the filehandle if requested this allows a multipart MIME
- ## upload to contain many files, and we won't die due to too many
- ## open file handles. The user can access the files using the hash
- ## below.
- close $filehandle if $CLOSE_UPLOAD_FILES;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
-
- # Save some information about the uploaded file where we can get
- # at it later.
- # Use the typeglob as the key, as this is guaranteed to be
- # unique for each filehandle. Don't use the file descriptor as
- # this will be re-used for each filehandle if the
- # close_upload_files feature is used.
- $self->{'.tmpfiles'}->{$$filehandle}= {
- hndl => $filehandle,
- name => $tmpfile,
- info => {%header},
- };
- push(@{$self->{param}{$param}},$filehandle);
- }
- }
- return $returnvalue;
-}
-END_OF_FUNC
-
-
-'upload' =><<'END_OF_FUNC',
-sub upload {
- my($self,$param_name) = self_or_default(@_);
- my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
- return unless @param;
- return wantarray ? @param : $param[0];
-}
-END_OF_FUNC
-
-'tmpFileName' => <<'END_OF_FUNC',
-sub tmpFileName {
- my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$$filename}->{name} ?
- $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
- : '';
-}
-END_OF_FUNC
-
-'uploadInfo' => <<'END_OF_FUNC',
-sub uploadInfo {
- my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$$filename}->{info};
-}
-END_OF_FUNC
-
-# internal routine, don't use
-'_set_values_and_labels' => <<'END_OF_FUNC',
-sub _set_values_and_labels {
- my $self = shift;
- my ($v,$l,$n) = @_;
- $$l = $v if ref($v) eq 'HASH' && !ref($$l);
- return $self->param($n) if !defined($v);
- return $v if !ref($v);
- return ref($v) eq 'HASH' ? keys %$v : @$v;
-}
-END_OF_FUNC
-
-# internal routine, don't use
-'_set_attributes' => <<'END_OF_FUNC',
-sub _set_attributes {
- my $self = shift;
- my($element, $attributes) = @_;
- return '' unless defined($attributes->{$element});
- $attribs = ' ';
- for my $attrib (keys %{$attributes->{$element}}) {
- (my $clean_attrib = $attrib) =~ s/^-//;
- $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
- }
- $attribs =~ s/ $//;
- return $attribs;
-}
-END_OF_FUNC
-
-'_compile_all' => <<'END_OF_FUNC',
-sub _compile_all {
- for (@_) {
- next if defined(&$_);
- $AUTOLOAD = "CGI::$_";
- _compile();
- }
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-;
-
-#########################################################
-# Globals and stubs for other packages that we use.
-#########################################################
-
-################### Fh -- lightweight filehandle ###############
-package Fh;
-
-use overload
- '""' => \&asString,
- 'cmp' => \&compare,
- 'fallback'=>1;
-
-$FH='fh00000';
-
-*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
-
-sub DESTROY {
- my $self = shift;
- close $self;
-}
-
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-'asString' => <<'END_OF_FUNC',
-sub asString {
- my $self = shift;
- # get rid of package name
- (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
- $i =~ s/%(..)/ chr(hex($1)) /eg;
- return $i.$CGI::TAINTED;
-# BEGIN DEAD CODE
-# This was an extremely clever patch that allowed "use strict refs".
-# Unfortunately it relied on another bug that caused leaky file descriptors.
-# The underlying bug has been fixed, so this no longer works. However
-# "strict refs" still works for some reason.
-# my $self = shift;
-# return ${*{$self}{SCALAR}};
-# END DEAD CODE
-}
-END_OF_FUNC
-
-'compare' => <<'END_OF_FUNC',
-sub compare {
- my $self = shift;
- my $value = shift;
- return "$self" cmp $value;
-}
-END_OF_FUNC
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($pack,$name,$file,$delete) = @_;
- _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
- require Fcntl unless defined &Fcntl::O_RDWR;
- (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
- my $fv = ++$FH . $safename;
- my $ref = \*{"Fh::$fv"};
-
- # Note this same regex is also used elsewhere in the same file for CGITempFile::new
- $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\\+-]+)$! || return;
- my $safe = $1;
- sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
- unlink($safe) if $delete;
- CORE::delete $Fh::{$fv};
- return bless $ref,$pack;
-}
-END_OF_FUNC
-
-'handle' => <<'END_OF_FUNC',
-sub handle {
- my $self = shift;
- eval "require IO::Handle" unless IO::Handle->can('new_from_fd');
- return IO::Handle->new_from_fd(fileno $self,"<");
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-######################## MultipartBuffer ####################
-package MultipartBuffer;
-
-use constant DEBUG => 0;
-
-# how many bytes to read at a time. We use
-# a 4K buffer by default.
-$INITIAL_FILLUNIT = 1024 * 4;
-$TIMEOUT = 240*60; # 4 hour timeout for big files
-$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
-$CRLF=$CGI::CRLF;
-
-#reuse the autoload function
-*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
-
-# avoid autoloader warnings
-sub DESTROY {}
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($package,$interface,$boundary,$length) = @_;
- $FILLUNIT = $INITIAL_FILLUNIT;
- $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
-
- # If the user types garbage into the file upload field,
- # then Netscape passes NOTHING to the server (not good).
- # We may hang on this read in that case. So we implement
- # a read timeout. If nothing is ready to read
- # by then, we return.
-
- # Netscape seems to be a little bit unreliable
- # about providing boundary strings.
- my $boundary_read = 0;
- if ($boundary) {
-
- # Under the MIME spec, the boundary consists of the
- # characters "--" PLUS the Boundary string
-
- # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
- # the two extra hyphens. We do a special case here on the user-agent!!!!
- $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
-
- } else { # otherwise we find it ourselves
- my($old);
- ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
- $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
- $length -= length($boundary);
- chomp($boundary); # remove the CRLF
- $/ = $old; # restore old line separator
- $boundary_read++;
- }
-
- my $self = {LENGTH=>$length,
- CHUNKED=>!$length,
- BOUNDARY=>$boundary,
- INTERFACE=>$interface,
- BUFFER=>'',
- };
-
- $FILLUNIT = length($boundary)
- if length($boundary) > $FILLUNIT;
-
- my $retval = bless $self,ref $package || $package;
-
- # Read the preamble and the topmost (boundary) line plus the CRLF.
- unless ($boundary_read) {
- while ($self->read(0)) { }
- }
- die "Malformed multipart POST: data truncated\n" if $self->eof;
-
- return $retval;
-}
-END_OF_FUNC
-
-'readHeader' => <<'END_OF_FUNC',
-sub readHeader {
- my($self) = @_;
- my($end);
- my($ok) = 0;
- my($bad) = 0;
-
- local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
-
- do {
- $self->fillBuffer($FILLUNIT);
- $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
- $ok++ if $self->{BUFFER} eq '';
- $bad++ if !$ok && $self->{LENGTH} <= 0;
- # this was a bad idea
- # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
- } until $ok || $bad;
- return () if $bad;
-
- #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
-
- my($header) = substr($self->{BUFFER},0,$end+2);
- substr($self->{BUFFER},0,$end+4) = '';
- my %return;
-
- if ($CGI::EBCDIC) {
- warn "untranslated header=$header\n" if DEBUG;
- $header = CGI::Util::ascii2ebcdic($header);
- warn "translated header=$header\n" if DEBUG;
- }
-
- # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
- # (Folding Long Header Fields), 3.4.3 (Comments)
- # and 3.4.5 (Quoted-Strings).
-
- my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
- $header=~s/$CRLF\s+/ /og; # merge continuation lines
-
- while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
- my ($field_name,$field_value) = ($1,$2);
- $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
- $return{$field_name}=$field_value;
- }
- return %return;
-}
-END_OF_FUNC
-
-# This reads and returns the body as a single scalar value.
-'readBody' => <<'END_OF_FUNC',
-sub readBody {
- my($self) = @_;
- my($data);
- my($returnval)='';
-
- #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
-
- while (defined($data = $self->read)) {
- $returnval .= $data;
- }
-
- if ($CGI::EBCDIC) {
- warn "untranslated body=$returnval\n" if DEBUG;
- $returnval = CGI::Util::ascii2ebcdic($returnval);
- warn "translated body=$returnval\n" if DEBUG;
- }
- return $returnval;
-}
-END_OF_FUNC
-
-# This will read $bytes or until the boundary is hit, whichever happens
-# first. After the boundary is hit, we return undef. The next read will
-# skip over the boundary and begin reading again;
-'read' => <<'END_OF_FUNC',
-sub read {
- my($self,$bytes) = @_;
-
- # default number of bytes to read
- $bytes = $bytes || $FILLUNIT;
-
- # Fill up our internal buffer in such a way that the boundary
- # is never split between reads.
- $self->fillBuffer($bytes);
-
- my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
- my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
-
- # Find the boundary in the buffer (it may not be there).
- my $start = index($self->{BUFFER},$boundary_start);
-
- warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
-
- # protect against malformed multipart POST operations
- die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
-
- #EBCDIC NOTE: want to translate boundary search into ASCII here.
-
- # If the boundary begins the data, then skip past it
- # and return undef.
- if ($start == 0) {
-
- # clear us out completely if we've hit the last boundary.
- if (index($self->{BUFFER},$boundary_end)==0) {
- $self->{BUFFER}='';
- $self->{LENGTH}=0;
- return undef;
- }
-
- # just remove the boundary.
- substr($self->{BUFFER},0,length($boundary_start))='';
- $self->{BUFFER} =~ s/^\012\015?//;
- return undef;
- }
-
- my $bytesToReturn;
- if ($start > 0) { # read up to the boundary
- $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
- } else { # read the requested number of bytes
- # leave enough bytes in the buffer to allow us to read
- # the boundary. Thanks to Kevin Hendrick for finding
- # this one.
- $bytesToReturn = $bytes - (length($boundary_start)+1);
- }
-
- my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
- substr($self->{BUFFER},0,$bytesToReturn)='';
-
- # If we hit the boundary, remove the CRLF from the end.
- return ($bytesToReturn==$start)
- ? substr($returnval,0,-2) : $returnval;
-}
-END_OF_FUNC
-
-
-# This fills up our internal buffer in such a way that the
-# boundary is never split between reads
-'fillBuffer' => <<'END_OF_FUNC',
-sub fillBuffer {
- my($self,$bytes) = @_;
- return unless $self->{CHUNKED} || $self->{LENGTH};
-
- my($boundaryLength) = length($self->{BOUNDARY});
- my($bufferLength) = length($self->{BUFFER});
- my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
- $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead;
-
- # Try to read some data. We may hang here if the browser is screwed up.
- my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
- $bytesToRead,
- $bufferLength);
- warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
- $self->{BUFFER} = '' unless defined $self->{BUFFER};
-
- # An apparent bug in the Apache server causes the read()
- # to return zero bytes repeatedly without blocking if the
- # remote user aborts during a file transfer. I don't know how
- # they manage this, but the workaround is to abort if we get
- # more than SPIN_LOOP_MAX consecutive zero reads.
- if ($bytesRead <= 0) {
- die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
- if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
- } else {
- $self->{ZERO_LOOP_COUNTER}=0;
- }
-
- $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
-}
-END_OF_FUNC
-
-
-# Return true when we've finished reading
-'eof' => <<'END_OF_FUNC'
-sub eof {
- my($self) = @_;
- return 1 if (length($self->{BUFFER}) == 0)
- && ($self->{LENGTH} <= 0);
- undef;
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-####################################################################################
-################################## TEMPORARY FILES #################################
-####################################################################################
-package CGITempFile;
-
-sub find_tempdir {
- $SL = $CGI::SL;
- $MAC = $CGI::OS eq 'MACINTOSH';
- my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
- unless (defined $TMPDIRECTORY) {
- @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
- "C:${SL}temp","${SL}tmp","${SL}temp",
- "${vol}${SL}Temporary Items",
- "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
- "C:${SL}system${SL}temp");
-
- if( $CGI::OS eq 'WINDOWS' ){
- # PeterH: These evars may not exist if this is invoked within a service and untainting
- # is in effect - with 'use warnings' the undefined array entries causes Perl to die
- unshift(@TEMP,$ENV{TEMP}) if defined $ENV{TEMP};
- unshift(@TEMP,$ENV{TMP}) if defined $ENV{TMP};
- unshift(@TEMP,$ENV{WINDIR} . $SL . 'TEMP') if defined $ENV{WINDIR};
- }
-
- unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
-
- # this feature was supposed to provide per-user tmpfiles, but
- # it is problematic.
- # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
- # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
- # : can generate a 'getpwuid() not implemented' exception, even though
- # : it's never called. Found under DOS/Win with the DJGPP perl port.
- # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
- # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
-
- for (@TEMP) {
- do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
- }
- }
- $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
-}
-
-find_tempdir();
-
-$MAXTRIES = 5000;
-
-# cute feature, but overload implementation broke it
-# %OVERLOAD = ('""'=>'as_string');
-*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
-
-sub DESTROY {
- my($self) = @_;
- $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return;
- my $safe = $1; # untaint operation
- unlink $safe; # get rid of the file
-}
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($package,$sequence) = @_;
- my $filename;
- unless (-w $TMPDIRECTORY) {
- $TMPDIRECTORY = undef;
- find_tempdir();
- }
- for (my $i = 0; $i < $MAXTRIES; $i++) {
- last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
- }
- # check that it is a more-or-less valid filename
- # Note this same regex is also used elsewhere in the same file for Fh::new
- return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\\+-]+)$!;
- # this used to untaint, now it doesn't
- # $filename = $1;
- return bless \$filename;
-}
-END_OF_FUNC
-
-'as_string' => <<'END_OF_FUNC'
-sub as_string {
- my($self) = @_;
- return $$self;
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-package CGI;
-
-# We get a whole bunch of warnings about "possibly uninitialized variables"
-# when running with the -w switch. Touch them all once to get rid of the
-# warnings. This is ugly and I hate it.
-if ($^W) {
- $CGI::CGI = '';
- $CGI::CGI=<<EOF;
- $CGI::VERSION;
- $MultipartBuffer::SPIN_LOOP_MAX;
- $MultipartBuffer::CRLF;
- $MultipartBuffer::TIMEOUT;
- $MultipartBuffer::INITIAL_FILLUNIT;
-EOF
- ;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI - Handle Common Gateway Interface requests and responses
-
-=head1 SYNOPSIS
-
- use CGI;
-
- my $q = CGI->new;
-
- # Process an HTTP request
- @values = $q->param('form_field');
-
- $fh = $q->upload('file_field');
-
- $riddle = $query->cookie('riddle_name');
- %answers = $query->cookie('answers');
-
- # Prepare various HTTP responses
- print $q->header();
- print $q->header('application/json');
-
- $cookie1 = $q->cookie(-name=>'riddle_name', -value=>"The Sphynx's Question");
- $cookie2 = $q->cookie(-name=>'answers', -value=>\%answers);
- print $q->header(
- -type => 'image/gif',
- -expires => '+3d',
- -cookie => [$cookie1,$cookie2]
- );
-
- print $q->redirect('http://somewhere.else/in/movie/land');
-
-=head1 DESCRIPTION
-
-CGI.pm is a stable, complete and mature solution for processing and preparing
-HTTP requests and responses. Major features including processing form
-submissions, file uploads, reading and writing cookies, query string generation
-and manipulation, and processing and preparing HTTP headers. Some HTML
-generation utilities are included as well.
-
-CGI.pm performs very well in a vanilla CGI.pm environment and also comes
-with built-in support for mod_perl and mod_perl2 as well as FastCGI.
-
-It has the benefit of having developed and refined over 10 years with input
-from dozens of contributors and being deployed on thousands of websites.
-CGI.pm has been included in the Perl distribution since Perl 5.4, and has
-become a de-facto standard.
-
-=head2 PROGRAMMING STYLE
-
-There are two styles of programming with CGI.pm, an object-oriented
-style and a function-oriented style. In the object-oriented style you
-create one or more CGI objects and then use object methods to create
-the various elements of the page. Each CGI object starts out with the
-list of named parameters that were passed to your CGI script by the
-server. You can modify the objects, save them to a file or database
-and recreate them. Because each object corresponds to the "state" of
-the CGI script, and because each object's parameter list is
-independent of the others, this allows you to save the state of the
-script and restore it later.
-
-For example, using the object oriented style, here is how you create
-a simple "Hello World" HTML page:
-
- #!/usr/local/bin/perl -w
- use CGI; # load CGI routines
- $q = CGI->new; # create new CGI object
- print $q->header, # create the HTTP header
- $q->start_html('hello world'), # start the HTML
- $q->h1('hello world'), # level 1 header
- $q->end_html; # end the HTML
-
-In the function-oriented style, there is one default CGI object that
-you rarely deal with directly. Instead you just call functions to
-retrieve CGI parameters, create HTML tags, manage cookies, and so
-on. This provides you with a cleaner programming interface, but
-limits you to using one CGI object at a time. The following example
-prints the same page, but uses the function-oriented interface.
-The main differences are that we now need to import a set of functions
-into our name space (usually the "standard" functions), and we don't
-need to create the CGI object.
-
- #!/usr/local/bin/perl
- use CGI qw/:standard/; # load standard CGI routines
- print header, # create the HTTP header
- start_html('hello world'), # start the HTML
- h1('hello world'), # level 1 header
- end_html; # end the HTML
-
-The examples in this document mainly use the object-oriented style.
-See HOW TO IMPORT FUNCTIONS for important information on
-function-oriented programming in CGI.pm
-
-=head2 CALLING CGI.PM ROUTINES
-
-Most CGI.pm routines accept several arguments, sometimes as many as 20
-optional ones! To simplify this interface, all routines use a named
-argument calling style that looks like this:
-
- print $q->header(-type=>'image/gif',-expires=>'+3d');
-
-Each argument name is preceded by a dash. Neither case nor order
-matters in the argument list. -type, -Type, and -TYPE are all
-acceptable. In fact, only the first argument needs to begin with a
-dash. If a dash is present in the first argument, CGI.pm assumes
-dashes for the subsequent ones.
-
-Several routines are commonly called with just one argument. In the
-case of these routines you can provide the single argument without an
-argument name. header() happens to be one of these routines. In this
-case, the single argument is the document type.
-
- print $q->header('text/html');
-
-Other such routines are documented below.
-
-Sometimes named arguments expect a scalar, sometimes a reference to an
-array, and sometimes a reference to a hash. Often, you can pass any
-type of argument and the routine will do whatever is most appropriate.
-For example, the param() routine is used to set a CGI parameter to a
-single or a multi-valued value. The two cases are shown below:
-
- $q->param(-name=>'veggie',-value=>'tomato');
- $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
-
-A large number of routines in CGI.pm actually aren't specifically
-defined in the module, but are generated automatically as needed.
-These are the "HTML shortcuts," routines that generate HTML tags for
-use in dynamically-generated pages. HTML tags have both attributes
-(the attribute="value" pairs within the tag itself) and contents (the
-part between the opening and closing pairs.) To distinguish between
-attributes and contents, CGI.pm uses the convention of passing HTML
-attributes as a hash reference as the first argument, and the
-contents, if any, as any subsequent arguments. It works out like
-this:
-
- Code Generated HTML
- ---- --------------
- h1() <h1>
- h1('some','contents'); <h1>some contents</h1>
- h1({-align=>left}); <h1 align="LEFT">
- h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
-
-HTML tags are described in more detail later.
-
-Many newcomers to CGI.pm are puzzled by the difference between the
-calling conventions for the HTML shortcuts, which require curly braces
-around the HTML tag attributes, and the calling conventions for other
-routines, which manage to generate attributes without the curly
-brackets. Don't be confused. As a convenience the curly braces are
-optional in all but the HTML shortcuts. If you like, you can use
-curly braces when calling any routine that takes named arguments. For
-example:
-
- print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
-
-If you use the B<-w> switch, you will be warned that some CGI.pm argument
-names conflict with built-in Perl functions. The most frequent of
-these is the -values argument, used to create multi-valued menus,
-radio button clusters and the like. To get around this warning, you
-have several choices:
-
-=over 4
-
-=item 1.
-
-Use another name for the argument, if one is available.
-For example, -value is an alias for -values.
-
-=item 2.
-
-Change the capitalization, e.g. -Values
-
-=item 3.
-
-Put quotes around the argument name, e.g. '-values'
-
-=back
-
-Many routines will do something useful with a named argument that it
-doesn't recognize. For example, you can produce non-standard HTTP
-header fields by providing them as named arguments:
-
- print $q->header(-type => 'text/html',
- -cost => 'Three smackers',
- -annoyance_level => 'high',
- -complaints_to => 'bit bucket');
-
-This will produce the following nonstandard HTTP header:
-
- HTTP/1.0 200 OK
- Cost: Three smackers
- Annoyance-level: high
- Complaints-to: bit bucket
- Content-type: text/html
-
-Notice the way that underscores are translated automatically into
-hyphens. HTML-generating routines perform a different type of
-translation.
-
-This feature allows you to keep up with the rapidly changing HTTP and
-HTML "standards".
-
-=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
-
- $query = CGI->new;
-
-This will parse the input (from POST, GET and DELETE methods) and store
-it into a perl5 object called $query.
-
-Any filehandles from file uploads will have their position reset to
-the beginning of the file.
-
-=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
-
- $query = CGI->new(INPUTFILE);
-
-If you provide a file handle to the new() method, it will read
-parameters from the file (or STDIN, or whatever). The file can be in
-any of the forms describing below under debugging (i.e. a series of
-newline delimited TAG=VALUE pairs will work). Conveniently, this type
-of file is created by the save() method (see below). Multiple records
-can be saved and restored.
-
-Perl purists will be pleased to know that this syntax accepts
-references to file handles, or even references to filehandle globs,
-which is the "official" way to pass a filehandle:
-
- $query = CGI->new(\*STDIN);
-
-You can also initialize the CGI object with a FileHandle or IO::File
-object.
-
-If you are using the function-oriented interface and want to
-initialize CGI state from a file handle, the way to do this is with
-B<restore_parameters()>. This will (re)initialize the
-default CGI object from the indicated file handle.
-
- open (IN,"test.in") || die;
- restore_parameters(IN);
- close IN;
-
-You can also initialize the query object from a hash
-reference:
-
- $query = CGI->new( {'dinosaur'=>'barney',
- 'song'=>'I love you',
- 'friends'=>[qw/Jessica George Nancy/]}
- );
-
-or from a properly formatted, URL-escaped query string:
-
- $query = CGI->new('dinosaur=barney&color=purple');
-
-or from a previously existing CGI object (currently this clones the
-parameter list, but none of the other object-specific fields, such as
-autoescaping):
-
- $old_query = CGI->new;
- $new_query = CGI->new($old_query);
-
-To create an empty query, initialize it from an empty string or hash:
-
- $empty_query = CGI->new("");
-
- -or-
-
- $empty_query = CGI->new({});
-
-=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
-
- @keywords = $query->keywords
-
-If the script was invoked as the result of an <ISINDEX> search, the
-parsed keywords can be obtained as an array using the keywords() method.
-
-=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
-
- @names = $query->param
-
-If the script was invoked with a parameter list
-(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
-will return the parameter names as a list. If the script was invoked
-as an <ISINDEX> script and contains a string without ampersands
-(e.g. "value1+value2+value3") , there will be a single parameter named
-"keywords" containing the "+"-delimited keywords.
-
-NOTE: As of version 1.5, the array of parameter names returned will
-be in the same order as they were submitted by the browser.
-Usually this order is the same as the order in which the
-parameters are defined in the form (however, this isn't part
-of the spec, and so isn't guaranteed).
-
-=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
-
- @values = $query->param('foo');
-
- -or-
-
- $value = $query->param('foo');
-
-Pass the param() method a single argument to fetch the value of the
-named parameter. If the parameter is multivalued (e.g. from multiple
-selections in a scrolling list), you can ask to receive an array. Otherwise
-the method will return a single value.
-
-If a value is not given in the query string, as in the queries
-"name1=&name2=", it will be returned as an empty string.
-
-
-If the parameter does not exist at all, then param() will return undef
-in a scalar context, and the empty list in a list context.
-
-
-=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
-
- $query->param('foo','an','array','of','values');
-
-This sets the value for the named parameter 'foo' to an array of
-values. This is one way to change the value of a field AFTER
-the script has been invoked once before. (Another way is with
-the -override parameter accepted by all methods that generate
-form elements.)
-
-param() also recognizes a named parameter style of calling described
-in more detail later:
-
- $query->param(-name=>'foo',-values=>['an','array','of','values']);
-
- -or-
-
- $query->param(-name=>'foo',-value=>'the value');
-
-=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
-
- $query->append(-name=>'foo',-values=>['yet','more','values']);
-
-This adds a value or list of values to the named parameter. The
-values are appended to the end of the parameter if it already exists.
-Otherwise the parameter is created. Note that this method only
-recognizes the named argument calling syntax.
-
-=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
-
- $query->import_names('R');
-
-This creates a series of variables in the 'R' namespace. For example,
-$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
-If no namespace is given, this method will assume 'Q'.
-WARNING: don't import anything into 'main'; this is a major security
-risk!!!!
-
-NOTE 1: Variable names are transformed as necessary into legal Perl
-variable names. All non-legal characters are transformed into
-underscores. If you need to keep the original names, you should use
-the param() method instead to access CGI variables by name.
-
-NOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
-this name has been removed completely to avoid conflict with the built-in
-Perl module B<import> operator.
-
-=head2 DELETING A PARAMETER COMPLETELY:
-
- $query->delete('foo','bar','baz');
-
-This completely clears a list of parameters. It sometimes useful for
-resetting parameters that you don't want passed down between script
-invocations.
-
-If you are using the function call interface, use "Delete()" instead
-to avoid conflicts with Perl's built-in delete operator.
-
-=head2 DELETING ALL PARAMETERS:
-
- $query->delete_all();
-
-This clears the CGI object completely. It might be useful to ensure
-that all the defaults are taken when you create a fill-out form.
-
-Use Delete_all() instead if you are using the function call interface.
-
-=head2 HANDLING NON-URLENCODED ARGUMENTS
-
-
-If POSTed data is not of type application/x-www-form-urlencoded or
-multipart/form-data, then the POSTed data will not be processed, but
-instead be returned as-is in a parameter named POSTDATA. To retrieve
-it, use code like this:
-
- my $data = $query->param('POSTDATA');
-
-Likewise if PUTed data can be retrieved with code like this:
-
- my $data = $query->param('PUTDATA');
-
-(If you don't know what the preceding means, don't worry about it. It
-only affects people trying to use CGI for XML processing and other
-specialized tasks.)
-
-
-=head2 DIRECT ACCESS TO THE PARAMETER LIST:
-
- $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
- unshift @{$q->param_fetch(-name=>'address')},'George Munster';
-
-If you need access to the parameter list in a way that isn't covered
-by the methods given in the previous sections, you can obtain a direct
-reference to it by
-calling the B<param_fetch()> method with the name of the parameter. This
-will return an array reference to the named parameter, which you then
-can manipulate in any way you like.
-
-You can also use a named argument style using the B<-name> argument.
-
-=head2 FETCHING THE PARAMETER LIST AS A HASH:
-
- $params = $q->Vars;
- print $params->{'address'};
- @foo = split("\0",$params->{'foo'});
- %params = $q->Vars;
-
- use CGI ':cgi-lib';
- $params = Vars;
-
-Many people want to fetch the entire parameter list as a hash in which
-the keys are the names of the CGI parameters, and the values are the
-parameters' values. The Vars() method does this. Called in a scalar
-context, it returns the parameter list as a tied hash reference.
-Changing a key changes the value of the parameter in the underlying
-CGI parameter list. Called in a list context, it returns the
-parameter list as an ordinary hash. This allows you to read the
-contents of the parameter list, but not to change it.
-
-When using this, the thing you must watch out for are multivalued CGI
-parameters. Because a hash cannot distinguish between scalar and
-list context, multivalued parameters will be returned as a packed
-string, separated by the "\0" (null) character. You must split this
-packed string in order to get at the individual values. This is the
-convention introduced long ago by Steve Brenner in his cgi-lib.pl
-module for Perl version 4.
-
-If you wish to use Vars() as a function, import the I<:cgi-lib> set of
-function calls (also see the section on CGI-LIB compatibility).
-
-=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
-
- $query->save(\*FILEHANDLE)
-
-This will write the current state of the form to the provided
-filehandle. You can read it back in by providing a filehandle
-to the new() method. Note that the filehandle can be a file, a pipe,
-or whatever!
-
-The format of the saved file is:
-
- NAME1=VALUE1
- NAME1=VALUE1'
- NAME2=VALUE2
- NAME3=VALUE3
- =
-
-Both name and value are URL escaped. Multi-valued CGI parameters are
-represented as repeated names. A session record is delimited by a
-single = symbol. You can write out multiple records and read them
-back in with several calls to B<new>. You can do this across several
-sessions by opening the file in append mode, allowing you to create
-primitive guest books, or to keep a history of users' queries. Here's
-a short example of creating multiple session records:
-
- use CGI;
-
- open (OUT,'>>','test.out') || die;
- $records = 5;
- for (0..$records) {
- my $q = CGI->new;
- $q->param(-name=>'counter',-value=>$_);
- $q->save(\*OUT);
- }
- close OUT;
-
- # reopen for reading
- open (IN,'<','test.out') || die;
- while (!eof(IN)) {
- my $q = CGI->new(\*IN);
- print $q->param('counter'),"\n";
- }
-
-The file format used for save/restore is identical to that used by the
-Whitehead Genome Center's data exchange format "Boulderio", and can be
-manipulated and even databased using Boulderio utilities. See
-
- http://stein.cshl.org/boulder/
-
-for further details.
-
-If you wish to use this method from the function-oriented (non-OO)
-interface, the exported name for this method is B<save_parameters()>.
-
-=head2 RETRIEVING CGI ERRORS
-
-Errors can occur while processing user input, particularly when
-processing uploaded files. When these errors occur, CGI will stop
-processing and return an empty parameter list. You can test for
-the existence and nature of errors using the I<cgi_error()> function.
-The error messages are formatted as HTTP status codes. You can either
-incorporate the error text into an HTML page, or use it as the value
-of the HTTP status:
-
- my $error = $q->cgi_error;
- if ($error) {
- print $q->header(-status=>$error),
- $q->start_html('Problems'),
- $q->h2('Request not processed'),
- $q->strong($error);
- exit 0;
- }
-
-When using the function-oriented interface (see the next section),
-errors may only occur the first time you call I<param()>. Be ready
-for this!
-
-=head2 USING THE FUNCTION-ORIENTED INTERFACE
-
-To use the function-oriented interface, you must specify which CGI.pm
-routines or sets of routines to import into your script's namespace.
-There is a small overhead associated with this importation, but it
-isn't much.
-
- use CGI <list of methods>;
-
-The listed methods will be imported into the current package; you can
-call them directly without creating a CGI object first. This example
-shows how to import the B<param()> and B<header()>
-methods, and then use them directly:
-
- use CGI 'param','header';
- print header('text/plain');
- $zipcode = param('zipcode');
-
-More frequently, you'll import common sets of functions by referring
-to the groups by name. All function sets are preceded with a ":"
-character as in ":html3" (for tags defined in the HTML 3 standard).
-
-Here is a list of the function sets you can import:
-
-=over 4
-
-=item B<:cgi>
-
-Import all CGI-handling methods, such as B<param()>, B<path_info()>
-and the like.
-
-=item B<:form>
-
-Import all fill-out form generating methods, such as B<textfield()>.
-
-=item B<:html2>
-
-Import all methods that generate HTML 2.0 standard elements.
-
-=item B<:html3>
-
-Import all methods that generate HTML 3.0 elements (such as
-<table>, <super> and <sub>).
-
-=item B<:html4>
-
-Import all methods that generate HTML 4 elements (such as
-<abbrev>, <acronym> and <thead>).
-
-=item B<:netscape>
-
-Import the <blink>, <fontsize> and <center> tags.
-
-=item B<:html>
-
-Import all HTML-generating shortcuts (i.e. 'html2', 'html3', 'html4' and 'netscape')
-
-=item B<:standard>
-
-Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
-
-=item B<:all>
-
-Import all the available methods. For the full list, see the CGI.pm
-code, where the variable %EXPORT_TAGS is defined.
-
-=back
-
-If you import a function name that is not part of CGI.pm, the module
-will treat it as a new HTML tag and generate the appropriate
-subroutine. You can then use it like any other HTML tag. This is to
-provide for the rapidly-evolving HTML "standard." For example, say
-Microsoft comes out with a new tag called <gradient> (which causes the
-user's desktop to be flooded with a rotating gradient fill until his
-machine reboots). You don't need to wait for a new version of CGI.pm
-to start using it immediately:
-
- use CGI qw/:standard :html3 gradient/;
- print gradient({-start=>'red',-end=>'blue'});
-
-Note that in the interests of execution speed CGI.pm does B<not> use
-the standard L<Exporter> syntax for specifying load symbols. This may
-change in the future.
-
-If you import any of the state-maintaining CGI or form-generating
-methods, a default CGI object will be created and initialized
-automatically the first time you use any of the methods that require
-one to be present. This includes B<param()>, B<textfield()>,
-B<submit()> and the like. (If you need direct access to the CGI
-object, you can find it in the global variable B<$CGI::Q>). By
-importing CGI.pm methods, you can create visually elegant scripts:
-
- use CGI qw/:standard/;
- print
- header,
- start_html('Simple Script'),
- h1('Simple Script'),
- start_form,
- "What's your name? ",textfield('name'),p,
- "What's the combination?",
- checkbox_group(-name=>'words',
- -values=>['eenie','meenie','minie','moe'],
- -defaults=>['eenie','moe']),p,
- "What's your favorite color?",
- popup_menu(-name=>'color',
- -values=>['red','green','blue','chartreuse']),p,
- submit,
- end_form,
- hr,"\n";
-
- if (param) {
- print
- "Your name is ",em(param('name')),p,
- "The keywords are: ",em(join(", ",param('words'))),p,
- "Your favorite color is ",em(param('color')),".\n";
- }
- print end_html;
-
-=head2 PRAGMAS
-
-In addition to the function sets, there are a number of pragmas that
-you can import. Pragmas, which are always preceded by a hyphen,
-change the way that CGI.pm functions in various ways. Pragmas,
-function sets, and individual functions can all be imported in the
-same use() line. For example, the following use statement imports the
-standard set of functions and enables debugging mode (pragma
--debug):
-
- use CGI qw/:standard -debug/;
-
-The current list of pragmas is as follows:
-
-=over 4
-
-=item -any
-
-When you I<use CGI -any>, then any method that the query object
-doesn't recognize will be interpreted as a new HTML tag. This allows
-you to support the next I<ad hoc> HTML
-extension. This lets you go wild with new and unsupported tags:
-
- use CGI qw(-any);
- $q=CGI->new;
- print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
-
-Since using <cite>any</cite> causes any mistyped method name
-to be interpreted as an HTML tag, use it with care or not at
-all.
-
-=item -compile
-
-This causes the indicated autoloaded methods to be compiled up front,
-rather than deferred to later. This is useful for scripts that run
-for an extended period of time under FastCGI or mod_perl, and for
-those destined to be crunched by Malcolm Beattie's Perl compiler. Use
-it in conjunction with the methods or method families you plan to use.
-
- use CGI qw(-compile :standard :html3);
-
-or even
-
- use CGI qw(-compile :all);
-
-Note that using the -compile pragma in this way will always have
-the effect of importing the compiled functions into the current
-namespace. If you want to compile without importing use the
-compile() method instead:
-
- use CGI();
- CGI->compile();
-
-This is particularly useful in a mod_perl environment, in which you
-might want to precompile all CGI routines in a startup script, and
-then import the functions individually in each mod_perl script.
-
-=item -nosticky
-
-By default the CGI module implements a state-preserving behavior
-called "sticky" fields. The way this works is that if you are
-regenerating a form, the methods that generate the form field values
-will interrogate param() to see if similarly-named parameters are
-present in the query string. If they find a like-named parameter, they
-will use it to set their default values.
-
-Sometimes this isn't what you want. The B<-nosticky> pragma prevents
-this behavior. You can also selectively change the sticky behavior in
-each element that you generate.
-
-=item -tabindex
-
-Automatically add tab index attributes to each form field. With this
-option turned off, you can still add tab indexes manually by passing a
--tabindex option to each field-generating method.
-
-=item -no_undef_params
-
-This keeps CGI.pm from including undef params in the parameter list.
-
-=item -no_xhtml
-
-By default, CGI.pm versions 2.69 and higher emit XHTML
-(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
-feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
-feature.
-
-If start_html()'s -dtd parameter specifies an HTML 2.0,
-3.2, 4.0 or 4.01 DTD,
-XHTML will automatically be disabled without needing to use this
-pragma.
-
-=item -utf8
-
-This makes CGI.pm treat all parameters as UTF-8 strings. Use this with
-care, as it will interfere with the processing of binary uploads. It
-is better to manually select which fields are expected to return utf-8
-strings and convert them using code like this:
-
- use Encode;
- my $arg = decode utf8=>param('foo');
-
-=item -nph
-
-This makes CGI.pm produce a header appropriate for an NPH (no
-parsed header) script. You may need to do other things as well
-to tell the server that the script is NPH. See the discussion
-of NPH scripts below.
-
-=item -newstyle_urls
-
-Separate the name=value pairs in CGI parameter query strings with
-semicolons rather than ampersands. For example:
-
- ?name=fred;age=24;favorite_color=3
-
-Semicolon-delimited query strings are always accepted, and will be emitted by
-self_url() and query_string(). newstyle_urls became the default in version
-2.64.
-
-=item -oldstyle_urls
-
-Separate the name=value pairs in CGI parameter query strings with
-ampersands rather than semicolons. This is no longer the default.
-
-=item -autoload
-
-This overrides the autoloader so that any function in your program
-that is not recognized is referred to CGI.pm for possible evaluation.
-This allows you to use all the CGI.pm functions without adding them to
-your symbol table, which is of concern for mod_perl users who are
-worried about memory consumption. I<Warning:> when
-I<-autoload> is in effect, you cannot use "poetry mode"
-(functions without the parenthesis). Use I<hr()> rather
-than I<hr>, or add something like I<use subs qw/hr p header/>
-to the top of your script.
-
-=item -no_debug
-
-This turns off the command-line processing features. If you want to
-run a CGI.pm script from the command line to produce HTML, and you
-don't want it to read CGI parameters from the command line or STDIN,
-then use this pragma:
-
- use CGI qw(-no_debug :standard);
-
-=item -debug
-
-This turns on full debugging. In addition to reading CGI arguments
-from the command-line processing, CGI.pm will pause and try to read
-arguments from STDIN, producing the message "(offline mode: enter
-name=value pairs on standard input)" features.
-
-See the section on debugging for more details.
-
-=item -private_tempfiles
-
-CGI.pm can process uploaded file. Ordinarily it spools the uploaded
-file to a temporary directory, then deletes the file when done.
-However, this opens the risk of eavesdropping as described in the file
-upload section. Another CGI script author could peek at this data
-during the upload, even if it is confidential information. On Unix
-systems, the -private_tempfiles pragma will cause the temporary file
-to be unlinked as soon as it is opened and before any data is written
-into it, reducing, but not eliminating the risk of eavesdropping
-(there is still a potential race condition). To make life harder for
-the attacker, the program chooses tempfile names by calculating a 32
-bit checksum of the incoming HTTP headers.
-
-To ensure that the temporary file cannot be read by other CGI scripts,
-use suEXEC or a CGI wrapper program to run your script. The temporary
-file is created with mode 0600 (neither world nor group readable).
-
-The temporary directory is selected using the following algorithm:
-
- 1. if $CGITempFile::TMPDIRECTORY is already set, use that
-
- 2. if the environment variable TMPDIR exists, use the location
- indicated.
-
- 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
- /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
-
-Each of these locations is checked that it is a directory and is
-writable. If not, the algorithm tries the next choice.
-
-=back
-
-=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
-
-Many of the methods generate HTML tags. As described below, tag
-functions automatically generate both the opening and closing tags.
-For example:
-
- print h1('Level 1 Header');
-
-produces
-
- <h1>Level 1 Header</h1>
-
-There will be some times when you want to produce the start and end
-tags yourself. In this case, you can use the form start_I<tag_name>
-and end_I<tag_name>, as in:
-
- print start_h1,'Level 1 Header',end_h1;
-
-With a few exceptions (described below), start_I<tag_name> and
-end_I<tag_name> functions are not generated automatically when you
-I<use CGI>. However, you can specify the tags you want to generate
-I<start/end> functions for by putting an asterisk in front of their
-name, or, alternatively, requesting either "start_I<tag_name>" or
-"end_I<tag_name>" in the import list.
-
-Example:
-
- use CGI qw/:standard *table start_ul/;
-
-In this example, the following functions are generated in addition to
-the standard ones:
-
-=over 4
-
-=item 1. start_table() (generates a <table> tag)
-
-=item 2. end_table() (generates a </table> tag)
-
-=item 3. start_ul() (generates a <ul> tag)
-
-=item 4. end_ul() (generates a </ul> tag)
-
-=back
-
-=head1 GENERATING DYNAMIC DOCUMENTS
-
-Most of CGI.pm's functions deal with creating documents on the fly.
-Generally you will produce the HTTP header first, followed by the
-document itself. CGI.pm provides functions for generating HTTP
-headers of various types as well as for generating HTML. For creating
-GIF images, see the GD.pm module.
-
-Each of these functions produces a fragment of HTML or HTTP which you
-can print out directly so that it displays in the browser window,
-append to a string, or save to a file for later use.
-
-=head2 CREATING A STANDARD HTTP HEADER:
-
-Normally the first thing you will do in any CGI script is print out an
-HTTP header. This tells the browser what type of document to expect,
-and gives other optional information, such as the language, expiration
-date, and whether to cache the document. The header can also be
-manipulated for special purposes, such as server push and pay per view
-pages.
-
- print header;
-
- -or-
-
- print header('image/gif');
-
- -or-
-
- print header('text/html','204 No response');
-
- -or-
-
- print header(-type=>'image/gif',
- -nph=>1,
- -status=>'402 Payment required',
- -expires=>'+3d',
- -cookie=>$cookie,
- -charset=>'utf-7',
- -attachment=>'foo.gif',
- -Cost=>'$2.00');
-
-header() returns the Content-type: header. You can provide your own
-MIME type if you choose, otherwise it defaults to text/html. An
-optional second parameter specifies the status code and a human-readable
-message. For example, you can specify 204, "No response" to create a
-script that tells the browser to do nothing at all. Note that RFC 2616 expects
-the human-readable phase to be there as well as the numeric status code.
-
-The last example shows the named argument style for passing arguments
-to the CGI methods using named parameters. Recognized parameters are
-B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
-parameters will be stripped of their initial hyphens and turned into
-header fields, allowing you to specify any HTTP header you desire.
-Internal underscores will be turned into hyphens:
-
- print header(-Content_length=>3002);
-
-Most browsers will not cache the output from CGI scripts. Every time
-the browser reloads the page, the script is invoked anew. You can
-change this behavior with the B<-expires> parameter. When you specify
-an absolute or relative expiration interval with this parameter, some
-browsers and proxy servers will cache the script's output until the
-indicated expiration date. The following forms are all valid for the
--expires field:
-
- +30s 30 seconds from now
- +10m ten minutes from now
- +1h one hour from now
- -1d yesterday (i.e. "ASAP!")
- now immediately
- +3M in three months
- +10y in ten years time
- Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
-
-The B<-cookie> parameter generates a header that tells the browser to provide
-a "magic cookie" during all subsequent transactions with your script.
-Some cookies have a special format that includes interesting attributes
-such as expiration time. Use the cookie() method to create and retrieve
-session cookies.
-
-The B<-nph> parameter, if set to a true value, will issue the correct
-headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers that expect all their scripts to be NPH.
-
-The B<-charset> parameter can be used to control the character set
-sent to the browser. If not provided, defaults to ISO-8859-1. As a
-side effect, this sets the charset() method as well.
-
-The B<-attachment> parameter can be used to turn the page into an
-attachment. Instead of displaying the page, some browsers will prompt
-the user to save it to disk. The value of the argument is the
-suggested name for the saved file. In order for this to work, you may
-have to set the B<-type> to "application/octet-stream".
-
-The B<-p3p> parameter will add a P3P tag to the outgoing header. The
-parameter can be an arrayref or a space-delimited string of P3P tags.
-For example:
-
- print header(-p3p=>[qw(CAO DSP LAW CURa)]);
- print header(-p3p=>'CAO DSP LAW CURa');
-
-In either case, the outgoing header will be formatted as:
-
- P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
-
-CGI.pm will accept valid multi-line headers when each line is separated with a
-CRLF value ("\r\n" on most platforms) followed by at least one space. For example:
-
- print header( -ingredients => "ham\r\n\seggs\r\n\sbacon" );
-
-Invalid multi-line header input will trigger in an exception. When multi-line headers
-are received, CGI.pm will always output them back as a single line, according to the
-folding rules of RFC 2616: the newlines will be removed, while the white space remains.
-
-=head2 GENERATING A REDIRECTION HEADER
-
- print $q->redirect('http://somewhere.else/in/movie/land');
-
-Sometimes you don't want to produce a document yourself, but simply
-redirect the browser elsewhere, perhaps choosing a URL based on the
-time of day or the identity of the user.
-
-The redirect() method redirects the browser to a different URL. If
-you use redirection like this, you should B<not> print out a header as
-well.
-
-You should always use full URLs (including the http: or ftp: part) in
-redirection requests. Relative URLs will not work correctly.
-
-You can also use named arguments:
-
- print $q->redirect(
- -uri=>'http://somewhere.else/in/movie/land',
- -nph=>1,
- -status=>'301 Moved Permanently');
-
-All names arguments recognized by header() are also recognized by
-redirect(). However, most HTTP headers, including those generated by
--cookie and -target, are ignored by the browser.
-
-The B<-nph> parameter, if set to a true value, will issue the correct
-headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers, such as Microsoft IIS, which
-expect all their scripts to be NPH.
-
-The B<-status> parameter will set the status of the redirect. HTTP
-defines three different possible redirection status codes:
-
- 301 Moved Permanently
- 302 Found
- 303 See Other
-
-The default if not specified is 302, which means "moved temporarily."
-You may change the status to another status code if you wish. Be
-advised that changing the status to anything other than 301, 302 or
-303 will probably break redirection.
-
-Note that the human-readable phrase is also expected to be present to conform
-with RFC 2616, section 6.1.
-
-=head2 CREATING THE HTML DOCUMENT HEADER
-
- print start_html(-title=>'Secrets of the Pyramids',
- -author=>'fred@capricorn.org',
- -base=>'true',
- -target=>'_blank',
- -meta=>{'keywords'=>'pharaoh secret mummy',
- 'copyright'=>'copyright 1996 King Tut'},
- -style=>{'src'=>'/styles/style1.css'},
- -BGCOLOR=>'blue');
-
-The start_html() routine creates the top of the
-page, along with a lot of optional information that controls the
-page's appearance and behavior.
-
-This method returns a canned HTML header and the opening <body> tag.
-All parameters are optional. In the named parameter form, recognized
-parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
-(see below for the explanation). Any additional parameters you
-provide, such as the unofficial BGCOLOR attribute, are added
-to the <body> tag. Additional parameters must be proceeded by a
-hyphen.
-
-The argument B<-xbase> allows you to provide an HREF for the <base> tag
-different from the current location, as in
-
- -xbase=>"http://home.mcom.com/"
-
-All relative links will be interpreted relative to this tag.
-
-The argument B<-target> allows you to provide a default target frame
-for all the links and fill-out forms on the page. B<This is a
-non-standard HTTP feature which only works with some browsers!>
-
- -target=>"answer_window"
-
-All relative links will be interpreted relative to this tag.
-You add arbitrary meta information to the header with the B<-meta>
-argument. This argument expects a reference to a hash
-containing name/value pairs of meta information. These will be turned
-into a series of header <meta> tags that look something like this:
-
- <meta name="keywords" content="pharaoh secret mummy">
- <meta name="description" content="copyright 1996 King Tut">
-
-To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
-below.
-
-The B<-style> argument is used to incorporate cascading stylesheets
-into your code. See the section on CASCADING STYLESHEETS for more
-information.
-
-The B<-lang> argument is used to incorporate a language attribute into
-the <html> tag. For example:
-
- print $q->start_html(-lang=>'fr-CA');
-
-The default if not specified is "en-US" for US English, unless the
--dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
-lang attribute is left off. You can force the lang attribute to left
-off in other cases by passing an empty string (-lang=>'').
-
-The B<-encoding> argument can be used to specify the character set for
-XHTML. It defaults to iso-8859-1 if not specified.
-
-The B<-dtd> argument can be used to specify a public DTD identifier string. For example:
-
- -dtd => '-//W3C//DTD HTML 4.01 Transitional//EN')
-
-Alternatively, it can take public and system DTD identifiers as an array:
-
- dtd => [ '-//W3C//DTD HTML 4.01 Transitional//EN', 'http://www.w3.org/TR/html4/loose.dtd' ]
-
-For the public DTD identifier to be considered, it must be valid. Otherwise it
-will be replaced by the default DTD. If the public DTD contains 'XHTML', CGI.pm
-will emit XML.
-
-The B<-declare_xml> argument, when used in conjunction with XHTML,
-will put a <?xml> declaration at the top of the HTML header. The sole
-purpose of this declaration is to declare the character set
-encoding. In the absence of -declare_xml, the output HTML will contain
-a <meta> tag that specifies the encoding, allowing the HTML to pass
-most validators. The default for -declare_xml is false.
-
-You can place other arbitrary HTML elements to the <head> section with the
-B<-head> tag. For example, to place a <link> element in the
-head section, use this:
-
- print start_html(-head=>Link({-rel=>'shortcut icon',
- -href=>'favicon.ico'}));
-
-To incorporate multiple HTML elements into the <head> section, just pass an
-array reference:
-
- print start_html(-head=>[
- Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}),
- Link({-rel=>'previous',
- -href=>'http://www.capricorn.com/s1.html'})
- ]
- );
-
-And here's how to create an HTTP-EQUIV <meta> tag:
-
- print start_html(-head=>meta({-http_equiv => 'Content-Type',
- -content => 'text/html'}))
-
-
-JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
-B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
-to add JavaScript calls to your pages. B<-script> should
-point to a block of text containing JavaScript function definitions.
-This block will be placed within a <script> block inside the HTML (not
-HTTP) header. The block is placed in the header in order to give your
-page a fighting chance of having all its JavaScript functions in place
-even if the user presses the stop button before the page has loaded
-completely. CGI.pm attempts to format the script in such a way that
-JavaScript-naive browsers will not choke on the code: unfortunately
-there are some browsers, such as Chimera for Unix, that get confused
-by it nevertheless.
-
-The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
-code to execute when the page is respectively opened and closed by the
-browser. Usually these parameters are calls to functions defined in the
-B<-script> field:
-
- $query = CGI->new;
- print header;
- $JSCRIPT=<<END;
- // Ask a silly question
- function riddle_me_this() {
- var r = prompt("What walks on four legs in the morning, " +
- "two legs in the afternoon, " +
- "and three legs in the evening?");
- response(r);
- }
- // Get a silly answer
- function response(answer) {
- if (answer == "man")
- alert("Right you are!");
- else
- alert("Wrong! Guess again.");
- }
- END
- print start_html(-title=>'The Riddle of the Sphinx',
- -script=>$JSCRIPT);
-
-Use the B<-noScript> parameter to pass some HTML text that will be displayed on
-browsers that do not have JavaScript (or browsers where JavaScript is turned
-off).
-
-The <script> tag, has several attributes including "type", "charset" and "src".
-"src" allows you to keep JavaScript code in an external file. To use these
-attributes pass a HASH reference in the B<-script> parameter containing one or
-more of -type, -src, or -code:
-
- print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>{-type=>'JAVASCRIPT',
- -src=>'/javascript/sphinx.js'}
- );
-
- print $q->(-title=>'The Riddle of the Sphinx',
- -script=>{-type=>'PERLSCRIPT',
- -code=>'print "hello world!\n;"'}
- );
-
-
-A final feature allows you to incorporate multiple <script> sections into the
-header. Just pass the list of script sections as an array reference.
-this allows you to specify different source files for different dialects
-of JavaScript. Example:
-
- print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>[
- { -type => 'text/javascript',
- -src => '/javascript/utilities10.js'
- },
- { -type => 'text/javascript',
- -src => '/javascript/utilities11.js'
- },
- { -type => 'text/jscript',
- -src => '/javascript/utilities12.js'
- },
- { -type => 'text/ecmascript',
- -src => '/javascript/utilities219.js'
- }
- ]
- );
-
-The option "-language" is a synonym for -type, and is supported for
-backwards compatibility.
-
-The old-style positional parameters are as follows:
-
-B<Parameters:>
-
-=over 4
-
-=item 1.
-
-The title
-
-=item 2.
-
-The author's e-mail address (will create a <link rev="MADE"> tag if present
-
-=item 3.
-
-A 'true' flag if you want to include a <base> tag in the header. This
-helps resolve relative addresses to absolute ones when the document is moved,
-but makes the document hierarchy non-portable. Use with care!
-
-=back
-
-Other parameters you want to include in the <body> tag may be appended
-to these. This is a good place to put HTML extensions, such as colors and
-wallpaper patterns.
-
-=head2 ENDING THE HTML DOCUMENT:
-
- print $q->end_html;
-
-This ends an HTML document by printing the </body></html> tags.
-
-=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
-
- $myself = $q->self_url;
- print q(<a href="$myself">I'm talking to myself.</a>);
-
-self_url() will return a URL, that, when selected, will reinvoke
-this script with all its state information intact. This is most
-useful when you want to jump around within the document using
-internal anchors but you don't want to disrupt the current contents
-of the form(s). Something like this will do the trick.
-
- $myself = $q->self_url;
- print "<a href=\"$myself#table1\">See table 1</a>";
- print "<a href=\"$myself#table2\">See table 2</a>";
- print "<a href=\"$myself#yourself\">See for yourself</a>";
-
-If you want more control over what's returned, using the B<url()>
-method instead.
-
-You can also retrieve the unprocessed query string with query_string():
-
- $the_string = $q->query_string();
-
-The behavior of calling query_string is currently undefined when the HTTP method is
-something other than GET.
-
-=head2 OBTAINING THE SCRIPT'S URL
-
- $full_url = url();
- $full_url = url(-full=>1); #alternative syntax
- $relative_url = url(-relative=>1);
- $absolute_url = url(-absolute=>1);
- $url_with_path = url(-path_info=>1);
- $url_with_path_and_query = url(-path_info=>1,-query=>1);
- $netloc = url(-base => 1);
-
-B<url()> returns the script's URL in a variety of formats. Called
-without any arguments, it returns the full form of the URL, including
-host name and port number
-
- http://your.host.com/path/to/script.cgi
-
-You can modify this format with the following named arguments:
-
-=over 4
-
-=item B<-absolute>
-
-If true, produce an absolute URL, e.g.
-
- /path/to/script.cgi
-
-=item B<-relative>
-
-Produce a relative URL. This is useful if you want to reinvoke your
-script with different parameters. For example:
-
- script.cgi
-
-=item B<-full>
-
-Produce the full URL, exactly as if called without any arguments.
-This overrides the -relative and -absolute arguments.
-
-=item B<-path> (B<-path_info>)
-
-Append the additional path information to the URL. This can be
-combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
-is provided as a synonym.
-
-=item B<-query> (B<-query_string>)
-
-Append the query string to the URL. This can be combined with
-B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
-as a synonym.
-
-=item B<-base>
-
-Generate just the protocol and net location, as in http://www.foo.com:8000
-
-=item B<-rewrite>
-
-If Apache's mod_rewrite is turned on, then the script name and path
-info probably won't match the request that the user sent. Set
--rewrite=>1 (default) to return URLs that match what the user sent
-(the original request URI). Set -rewrite=>0 to return URLs that match
-the URL after mod_rewrite's rules have run.
-
-=back
-
-=head2 MIXING POST AND URL PARAMETERS
-
- $color = url_param('color');
-
-It is possible for a script to receive CGI parameters in the URL as
-well as in the fill-out form by creating a form that POSTs to a URL
-containing a query string (a "?" mark followed by arguments). The
-B<param()> method will always return the contents of the POSTed
-fill-out form, ignoring the URL's query string. To retrieve URL
-parameters, call the B<url_param()> method. Use it in the same way as
-B<param()>. The main difference is that it allows you to read the
-parameters, but not set them.
-
-
-Under no circumstances will the contents of the URL query string
-interfere with similarly-named CGI parameters in POSTed forms. If you
-try to mix a URL query string with a form submitted with the GET
-method, the results will not be what you expect.
-
-=head1 CREATING STANDARD HTML ELEMENTS:
-
-CGI.pm defines general HTML shortcut methods for many HTML tags. HTML shortcuts are named after a single
-HTML element and return a fragment of HTML text. Example:
-
- print $q->blockquote(
- "Many years ago on the island of",
- $q->a({href=>"http://crete.org/"},"Crete"),
- "there lived a Minotaur named",
- $q->strong("Fred."),
- ),
- $q->hr;
-
-This results in the following HTML code (extra newlines have been
-added for readability):
-
- <blockquote>
- Many years ago on the island of
- <a href="http://crete.org/">Crete</a> there lived
- a minotaur named <strong>Fred.</strong>
- </blockquote>
- <hr>
-
-If you find the syntax for calling the HTML shortcuts awkward, you can
-import them into your namespace and dispense with the object syntax
-completely (see the next section for more details):
-
- use CGI ':standard';
- print blockquote(
- "Many years ago on the island of",
- a({href=>"http://crete.org/"},"Crete"),
- "there lived a minotaur named",
- strong("Fred."),
- ),
- hr;
-
-=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
-
-The HTML methods will accept zero, one or multiple arguments. If you
-provide no arguments, you get a single tag:
-
- print hr; # <hr>
-
-If you provide one or more string arguments, they are concatenated
-together with spaces and placed between opening and closing tags:
-
- print h1("Chapter","1"); # <h1>Chapter 1</h1>"
-
-If the first argument is a hash reference, then the keys
-and values of the hash become the HTML tag's attributes:
-
- print a({-href=>'fred.html',-target=>'_new'},
- "Open a new frame");
-
- <a href="fred.html",target="_new">Open a new frame</a>
-
-You may dispense with the dashes in front of the attribute names if
-you prefer:
-
- print img {src=>'fred.gif',align=>'LEFT'};
-
- <img align="LEFT" src="fred.gif">
-
-Sometimes an HTML tag attribute has no argument. For example, ordered
-lists can be marked as COMPACT. The syntax for this is an argument that
-that points to an undef string:
-
- print ol({compact=>undef},li('one'),li('two'),li('three'));
-
-Prior to CGI.pm version 2.41, providing an empty ('') string as an
-attribute argument was the same as providing undef. However, this has
-changed in order to accommodate those who want to create tags of the form
-<img alt="">. The difference is shown in these two pieces of code:
-
- CODE RESULT
- img({alt=>undef}) <img alt>
- img({alt=>''}) <img alt="">
-
-=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
-
-One of the cool features of the HTML shortcuts is that they are
-distributive. If you give them an argument consisting of a
-B<reference> to a list, the tag will be distributed across each
-element of the list. For example, here's one way to make an ordered
-list:
-
- print ul(
- li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
- );
-
-This example will result in HTML output that looks like this:
-
- <ul>
- <li type="disc">Sneezy</li>
- <li type="disc">Doc</li>
- <li type="disc">Sleepy</li>
- <li type="disc">Happy</li>
- </ul>
-
-This is extremely useful for creating tables. For example:
-
- print table({-border=>undef},
- caption('When Should You Eat Your Vegetables?'),
- Tr({-align=>'CENTER',-valign=>'TOP'},
- [
- th(['Vegetable', 'Breakfast','Lunch','Dinner']),
- td(['Tomatoes' , 'no', 'yes', 'yes']),
- td(['Broccoli' , 'no', 'no', 'yes']),
- td(['Onions' , 'yes','yes', 'yes'])
- ]
- )
- );
-
-=head2 HTML SHORTCUTS AND LIST INTERPOLATION
-
-Consider this bit of code:
-
- print blockquote(em('Hi'),'mom!'));
-
-It will ordinarily return the string that you probably expect, namely:
-
- <blockquote><em>Hi</em> mom!</blockquote>
-
-Note the space between the element "Hi" and the element "mom!".
-CGI.pm puts the extra space there using array interpolation, which is
-controlled by the magic $" variable. Sometimes this extra space is
-not what you want, for example, when you are trying to align a series
-of images. In this case, you can simply change the value of $" to an
-empty string.
-
- {
- local($") = '';
- print blockquote(em('Hi'),'mom!'));
- }
-
-I suggest you put the code in a block as shown here. Otherwise the
-change to $" will affect all subsequent code until you explicitly
-reset it.
-
-=head2 NON-STANDARD HTML SHORTCUTS
-
-A few HTML tags don't follow the standard pattern for various
-reasons.
-
-B<comment()> generates an HTML comment (<!-- comment -->). Call it
-like
-
- print comment('here is my comment');
-
-Because of conflicts with built-in Perl functions, the following functions
-begin with initial caps:
-
- Select
- Tr
- Link
- Delete
- Accept
- Sub
-
-In addition, start_html(), end_html(), start_form(), end_form(),
-start_multipart_form() and all the fill-out form tags are special.
-See their respective sections.
-
-=head2 AUTOESCAPING HTML
-
-By default, all HTML that is emitted by the form-generating functions
-is passed through a function called escapeHTML():
-
-=over 4
-
-=item $escaped_string = escapeHTML("unescaped string");
-
-Escape HTML formatting characters in a string.
-
-=back
-
-Provided that you have specified a character set of ISO-8859-1 (the
-default), the standard HTML escaping rules will be used. The "<"
-character becomes "<", ">" becomes ">", "&" becomes "&", and
-the quote character becomes """. In addition, the hexadecimal
-0x8b and 0x9b characters, which some browsers incorrectly interpret
-as the left and right angle-bracket characters, are replaced by their
-numeric character entities ("‹" and "›"). If you manually change
-the charset, either by calling the charset() method explicitly or by
-passing a -charset argument to header(), then B<all> characters will
-be replaced by their numeric entities, since CGI.pm has no lookup
-table for all the possible encodings.
-
-C<escapeHTML()> expects the supplied string to be a character string. This means you
-should Encode::decode data received from "outside" and Encode::encode your
-strings before sending them back outside. If your source code UTF-8 encoded and
-you want to upgrade string literals in your source to character strings, you
-can use "use utf8". See L<perlunitut>, L<perlunifaq> and L<perlunicode> for more
-information on how Perl handles the difference between bytes and characters.
-
-The automatic escaping does not apply to other shortcuts, such as
-h1(). You should call escapeHTML() yourself on untrusted data in
-order to protect your pages against nasty tricks that people may enter
-into guestbooks, etc.. To change the character set, use charset().
-To turn autoescaping off completely, use autoEscape(0):
-
-=over 4
-
-=item $charset = charset([$charset]);
-
-Get or set the current character set.
-
-=item $flag = autoEscape([$flag]);
-
-Get or set the value of the autoescape flag.
-
-=back
-
-=head2 PRETTY-PRINTING HTML
-
-By default, all the HTML produced by these functions comes out as one
-long line without carriage returns or indentation. This is yuck, but
-it does reduce the size of the documents by 10-20%. To get
-pretty-printed output, please use L<CGI::Pretty>, a subclass
-contributed by Brian Paulsen.
-
-=head1 CREATING FILL-OUT FORMS:
-
-I<General note> The various form-creating methods all return strings
-to the caller, containing the tag or tags that will create the requested
-form element. You are responsible for actually printing out these strings.
-It's set up this way so that you can place formatting tags
-around the form elements.
-
-I<Another note> The default values that you specify for the forms are only
-used the B<first> time the script is invoked (when there is no query
-string). On subsequent invocations of the script (when there is a query
-string), the former values are used even if they are blank.
-
-If you want to change the value of a field from its previous value, you have two
-choices:
-
-(1) call the param() method to set it.
-
-(2) use the -override (alias -force) parameter (a new feature in version 2.15).
-This forces the default value to be used, regardless of the previous value:
-
- print textfield(-name=>'field_name',
- -default=>'starting value',
- -override=>1,
- -size=>50,
- -maxlength=>80);
-
-I<Yet another note> By default, the text and labels of form elements are
-escaped according to HTML rules. This means that you can safely use
-"<CLICK ME>" as the label for a button. However, it also interferes with
-your ability to incorporate special HTML character sequences, such as Á,
-into your fields. If you wish to turn off automatic escaping, call the
-autoEscape() method with a false value immediately after creating the CGI object:
-
- $query = CGI->new;
- $query->autoEscape(0);
-
-Note that autoEscape() is exclusively used to effect the behavior of how some
-CGI.pm HTML generation functions handle escaping. Calling escapeHTML()
-explicitly will always escape the HTML.
-
-I<A Lurking Trap!> Some of the form-element generating methods return
-multiple tags. In a scalar context, the tags will be concatenated
-together with spaces, or whatever is the current value of the $"
-global. In a list context, the methods will return a list of
-elements, allowing you to modify them if you wish. Usually you will
-not notice this behavior, but beware of this:
-
- printf("%s\n",end_form())
-
-end_form() produces several tags, and only the first of them will be
-printed because the format only expects one value.
-
-<p>
-
-
-=head2 CREATING AN ISINDEX TAG
-
- print isindex(-action=>$action);
-
- -or-
-
- print isindex($action);
-
-Prints out an <isindex> tag. Not very exciting. The parameter
--action specifies the URL of the script to process the query. The
-default is to process the query with the current script.
-
-=head2 STARTING AND ENDING A FORM
-
- print start_form(-method=>$method,
- -action=>$action,
- -enctype=>$encoding);
- <... various form stuff ...>
- print end_form;
-
- -or-
-
- print start_form($method,$action,$encoding);
- <... various form stuff ...>
- print end_form;
-
-start_form() will return a <form> tag with the optional method,
-action and form encoding that you specify. The defaults are:
-
- method: POST
- action: this script
- enctype: application/x-www-form-urlencoded for non-XHTML
- multipart/form-data for XHTML, see multipart/form-data below.
-
-end_form() returns the closing </form> tag.
-
-Start_form()'s enctype argument tells the browser how to package the various
-fields of the form before sending the form to the server. Two
-values are possible:
-
-B<Note:> These methods were previously named startform() and endform().
-These methods are now DEPRECATED.
-Please use start_form() and end_form() instead.
-
-=over 4
-
-=item B<application/x-www-form-urlencoded>
-
-This is the older type of encoding. It is compatible with many CGI scripts and is
-suitable for short fields containing text data. For your
-convenience, CGI.pm stores the name of this encoding
-type in B<&CGI::URL_ENCODED>.
-
-=item B<multipart/form-data>
-
-This is the newer type of encoding.
-It is suitable for forms that contain very large fields or that
-are intended for transferring binary data. Most importantly,
-it enables the "file upload" feature. For
-your convenience, CGI.pm stores the name of this encoding type
-in B<&CGI::MULTIPART>
-
-Forms that use this type of encoding are not easily interpreted
-by CGI scripts unless they use CGI.pm or another library designed
-to handle them.
-
-If XHTML is activated (the default), then forms will be automatically
-created using this type of encoding.
-
-=back
-
-The start_form() method uses the older form of encoding by
-default unless XHTML is requested. If you want to use the
-newer form of encoding by default, you can call
-B<start_multipart_form()> instead of B<start_form()>. The
-method B<end_multipart_form()> is an alias to B<end_form()>.
-
-JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
-for use with JavaScript. The -name parameter gives the
-form a name so that it can be identified and manipulated by
-JavaScript functions. -onSubmit should point to a JavaScript
-function that will be executed just before the form is submitted to your
-server. You can use this opportunity to check the contents of the form
-for consistency and completeness. If you find something wrong, you
-can put up an alert box or maybe fix things up yourself. You can
-abort the submission by returning false from this function.
-
-Usually the bulk of JavaScript functions are defined in a <script>
-block in the HTML header and -onSubmit points to one of these function
-call. See start_html() for details.
-
-=head2 FORM ELEMENTS
-
-After starting a form, you will typically create one or more
-textfields, popup menus, radio groups and other form elements. Each
-of these elements takes a standard set of named arguments. Some
-elements also have optional arguments. The standard arguments are as
-follows:
-
-=over 4
-
-=item B<-name>
-
-The name of the field. After submission this name can be used to
-retrieve the field's value using the param() method.
-
-=item B<-value>, B<-values>
-
-The initial value of the field which will be returned to the script
-after form submission. Some form elements, such as text fields, take
-a single scalar -value argument. Others, such as popup menus, take a
-reference to an array of values. The two arguments are synonyms.
-
-=item B<-tabindex>
-
-A numeric value that sets the order in which the form element receives
-focus when the user presses the tab key. Elements with lower values
-receive focus first.
-
-=item B<-id>
-
-A string identifier that can be used to identify this element to
-JavaScript and DHTML.
-
-=item B<-override>
-
-A boolean, which, if true, forces the element to take on the value
-specified by B<-value>, overriding the sticky behavior described
-earlier for the B<-nosticky> pragma.
-
-=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
-
-These are used to assign JavaScript event handlers. See the
-JavaScripting section for more details.
-
-=back
-
-Other common arguments are described in the next section. In addition
-to these, all attributes described in the HTML specifications are
-supported.
-
-=head2 CREATING A TEXT FIELD
-
- print textfield(-name=>'field_name',
- -value=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print textfield('field_name','starting value',50,80);
-
-textfield() will return a text input field.
-
-B<Parameters>
-
-=over 4
-
-=item 1.
-
-The first parameter is the required name for the field (-name).
-
-=item 2.
-
-The optional second parameter is the default starting value for the field
-contents (-value, formerly known as -default).
-
-=item 3.
-
-The optional third parameter is the size of the field in
- characters (-size).
-
-=item 4.
-
-The optional fourth parameter is the maximum number of characters the
- field will accept (-maxlength).
-
-=back
-
-As with all these methods, the field will be initialized with its
-previous contents from earlier invocations of the script.
-When the form is processed, the value of the text field can be
-retrieved with:
-
- $value = param('foo');
-
-If you want to reset it from its initial value after the script has been
-called once, you can do so like this:
-
- param('foo',"I'm taking over this value!");
-
-=head2 CREATING A BIG TEXT FIELD
-
- print textarea(-name=>'foo',
- -default=>'starting value',
- -rows=>10,
- -columns=>50);
-
- -or
-
- print textarea('foo','starting value',10,50);
-
-textarea() is just like textfield, but it allows you to specify
-rows and columns for a multiline text entry box. You can provide
-a starting value for the field, which can be long and contain
-multiple lines.
-
-=head2 CREATING A PASSWORD FIELD
-
- print password_field(-name=>'secret',
- -value=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print password_field('secret','starting value',50,80);
-
-password_field() is identical to textfield(), except that its contents
-will be starred out on the web page.
-
-=head2 CREATING A FILE UPLOAD FIELD
-
- print filefield(-name=>'uploaded_file',
- -default=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print filefield('uploaded_file','starting value',50,80);
-
-filefield() will return a file upload field.
-In order to take full advantage of this I<you must use the new
-multipart encoding scheme> for the form. You can do this either
-by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
-or by calling the new method B<start_multipart_form()> instead of
-vanilla B<start_form()>.
-
-B<Parameters>
-
-=over 4
-
-=item 1.
-
-The first parameter is the required name for the field (-name).
-
-=item 2.
-
-The optional second parameter is the starting value for the field contents
-to be used as the default file name (-default).
-
-For security reasons, browsers don't pay any attention to this field,
-and so the starting value will always be blank. Worse, the field
-loses its "sticky" behavior and forgets its previous contents. The
-starting value field is called for in the HTML specification, however,
-and possibly some browser will eventually provide support for it.
-
-=item 3.
-
-The optional third parameter is the size of the field in
-characters (-size).
-
-=item 4.
-
-The optional fourth parameter is the maximum number of characters the
-field will accept (-maxlength).
-
-=back
-
-JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
-B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
-recognized. See textfield() for details.
-
-=head2 PROCESSING A FILE UPLOAD FIELD
-
-=head3 Basics
-
-When the form is processed, you can retrieve an L<IO::Handle> compatible
-handle for a file upload field like this:
-
- $lightweight_fh = $q->upload('field_name');
-
- # undef may be returned if it's not a valid file handle
- if (defined $lightweight_fh) {
- # Upgrade the handle to one compatible with IO::Handle:
- my $io_handle = $lightweight_fh->handle;
-
- open (OUTFILE,'>>','/usr/local/web/users/feedback');
- while ($bytesread = $io_handle->read($buffer,1024)) {
- print OUTFILE $buffer;
- }
- }
-
-In a list context, upload() will return an array of filehandles.
-This makes it possible to process forms that use the same name for
-multiple upload fields.
-
-If you want the entered file name for the file, you can just call param():
-
- $filename = $q->param('field_name');
-
-Different browsers will return slightly different things for the
-name. Some browsers return the filename only. Others return the full
-path to the file, using the path conventions of the user's machine.
-Regardless, the name returned is always the name of the file on the
-I<user's> machine, and is unrelated to the name of the temporary file
-that CGI.pm creates during upload spooling (see below).
-
-When a file is uploaded the browser usually sends along some
-information along with it in the format of headers. The information
-usually includes the MIME content type. To
-retrieve this information, call uploadInfo(). It returns a reference to
-a hash containing all the document headers.
-
- $filename = $q->param('uploaded_file');
- $type = $q->uploadInfo($filename)->{'Content-Type'};
- unless ($type eq 'text/html') {
- die "HTML FILES ONLY!";
- }
-
-If you are using a machine that recognizes "text" and "binary" data
-modes, be sure to understand when and how to use them (see the Camel book).
-Otherwise you may find that binary files are corrupted during file
-uploads.
-
-=head3 Accessing the temp files directly
-
-When processing an uploaded file, CGI.pm creates a temporary file on your hard
-disk and passes you a file handle to that file. After you are finished with the
-file handle, CGI.pm unlinks (deletes) the temporary file. If you need to you
-can access the temporary file directly. You can access the temp file for a file
-upload by passing the file name to the tmpFileName() method:
-
- $filename = $query->param('uploaded_file');
- $tmpfilename = $query->tmpFileName($filename);
-
-The temporary file will be deleted automatically when your program exits unless
-you manually rename it. On some operating systems (such as Windows NT), you
-will need to close the temporary file's filehandle before your program exits.
-Otherwise the attempt to delete the temporary file will fail.
-
-=head3 Handling interrupted file uploads
-
-There are occasionally problems involving parsing the uploaded file.
-This usually happens when the user presses "Stop" before the upload is
-finished. In this case, CGI.pm will return undef for the name of the
-uploaded file and set I<cgi_error()> to the string "400 Bad request
-(malformed multipart POST)". This error message is designed so that
-you can incorporate it into a status code to be sent to the browser.
-Example:
-
- $file = $q->upload('uploaded_file');
- if (!$file && $q->cgi_error) {
- print $q->header(-status=>$q->cgi_error);
- exit 0;
- }
-
-You are free to create a custom HTML page to complain about the error,
-if you wish.
-
-=head3 Progress bars for file uploads and avoiding temp files
-
-CGI.pm gives you low-level access to file upload management through
-a file upload hook. You can use this feature to completely turn off
-the temp file storage of file uploads, or potentially write your own
-file upload progress meter.
-
-This is much like the UPLOAD_HOOK facility available in L<Apache::Request>, with
-the exception that the first argument to the callback is an L<Apache::Upload>
-object, here it's the remote filename.
-
- $q = CGI->new(\&hook [,$data [,$use_tempfile]]);
-
- sub hook {
- my ($filename, $buffer, $bytes_read, $data) = @_;
- print "Read $bytes_read bytes of $filename\n";
- }
-
-The C<< $data >> field is optional; it lets you pass configuration
-information (e.g. a database handle) to your hook callback.
-
-The C<< $use_tempfile >> field is a flag that lets you turn on and off
-CGI.pm's use of a temporary disk-based file during file upload. If you
-set this to a FALSE value (default true) then $q->param('uploaded_file')
-will no longer work, and the only way to get at the uploaded data is
-via the hook you provide.
-
-If using the function-oriented interface, call the CGI::upload_hook()
-method before calling param() or any other CGI functions:
-
- CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
-
-This method is not exported by default. You will have to import it
-explicitly if you wish to use it without the CGI:: prefix.
-
-=head3 Troubleshooting file uploads on Windows
-
-If you are using CGI.pm on a Windows platform and find that binary
-files get slightly larger when uploaded but that text files remain the
-same, then you have forgotten to activate binary mode on the output
-filehandle. Be sure to call binmode() on any handle that you create
-to write the uploaded file to disk.
-
-=head3 Older ways to process file uploads
-
-( This section is here for completeness. if you are building a new application with CGI.pm, you can skip it. )
-
-The original way to process file uploads with CGI.pm was to use param(). The
-value it returns has a dual nature as both a file name and a lightweight
-filehandle. This dual nature is problematic if you following the recommended
-practice of having C<use strict> in your code. Perl will complain when you try
-to use a string as a filehandle. More seriously, it is possible for the remote
-user to type garbage into the upload field, in which case what you get from
-param() is not a filehandle at all, but a string.
-
-To solve this problem the upload() method was added, which always returns a
-lightweight filehandle. This generally works well, but will have trouble
-interoperating with some other modules because the file handle is not derived
-from L<IO::Handle>. So that brings us to current recommendation given above,
-which is to call the handle() method on the file handle returned by upload().
-That upgrades the handle to an IO::Handle. It's a big win for compatibility for
-a small penalty of loading IO::Handle the first time you call it.
-
-
-=head2 CREATING A POPUP MENU
-
- print popup_menu('menu_name',
- ['eenie','meenie','minie'],
- 'meenie');
-
- -or-
-
- %labels = ('eenie'=>'your first choice',
- 'meenie'=>'your second choice',
- 'minie'=>'your third choice');
- %attributes = ('eenie'=>{'class'=>'class of first choice'});
- print popup_menu('menu_name',
- ['eenie','meenie','minie'],
- 'meenie',\%labels,\%attributes);
-
- -or (named parameter style)-
-
- print popup_menu(-name=>'menu_name',
- -values=>['eenie','meenie','minie'],
- -default=>['meenie','minie'],
- -labels=>\%labels,
- -attributes=>\%attributes);
-
-popup_menu() creates a menu.
-
-=over 4
-
-=item 1.
-
-The required first argument is the menu's name (-name).
-
-=item 2.
-
-The required second argument (-values) is an array B<reference>
-containing the list of menu items in the menu. You can pass the
-method an anonymous array, as shown in the example, or a reference to
-a named array, such as "\@foo".
-
-=item 3.
-
-The optional third parameter (-default) is the name of the default
-menu choice. If not specified, the first item will be the default.
-The values of the previous choice will be maintained across
-queries. Pass an array reference to select multiple defaults.
-
-=item 4.
-
-The optional fourth parameter (-labels) is provided for people who
-want to use different values for the user-visible label inside the
-popup menu and the value returned to your script. It's a pointer to an
-hash relating menu values to user-visible labels. If you
-leave this parameter blank, the menu values will be displayed by
-default. (You can also leave a label undefined if you want to).
-
-=item 5.
-
-The optional fifth parameter (-attributes) is provided to assign
-any of the common HTML attributes to an individual menu item. It's
-a pointer to a hash relating menu values to another
-hash with the attribute's name as the key and the
-attribute's value as the value.
-
-=back
-
-When the form is processed, the selected value of the popup menu can
-be retrieved using:
-
- $popup_menu_value = param('menu_name');
-
-=head2 CREATING AN OPTION GROUP
-
-Named parameter style
-
- print popup_menu(-name=>'menu_name',
- -values=>[qw/eenie meenie minie/,
- optgroup(-name=>'optgroup_name',
- -values => ['moe','catch'],
- -attributes=>{'catch'=>{'class'=>'red'}})],
- -labels=>{'eenie'=>'one',
- 'meenie'=>'two',
- 'minie'=>'three'},
- -default=>'meenie');
-
- Old style
- print popup_menu('menu_name',
- ['eenie','meenie','minie',
- optgroup('optgroup_name', ['moe', 'catch'],
- {'catch'=>{'class'=>'red'}})],'meenie',
- {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
-
-optgroup() creates an option group within a popup menu.
-
-=over 4
-
-=item 1.
-
-The required first argument (B<-name>) is the label attribute of the
-optgroup and is B<not> inserted in the parameter list of the query.
-
-=item 2.
-
-The required second argument (B<-values>) is an array reference
-containing the list of menu items in the menu. You can pass the
-method an anonymous array, as shown in the example, or a reference
-to a named array, such as \@foo. If you pass a HASH reference,
-the keys will be used for the menu values, and the values will be
-used for the menu labels (see -labels below).
-
-=item 3.
-
-The optional third parameter (B<-labels>) allows you to pass a reference
-to a hash containing user-visible labels for one or more
-of the menu items. You can use this when you want the user to see one
-menu string, but have the browser return your program a different one.
-If you don't specify this, the value string will be used instead
-("eenie", "meenie" and "minie" in this example). This is equivalent
-to using a hash reference for the -values parameter.
-
-=item 4.
-
-An optional fourth parameter (B<-labeled>) can be set to a true value
-and indicates that the values should be used as the label attribute
-for each option element within the optgroup.
-
-=item 5.
-
-An optional fifth parameter (-novals) can be set to a true value and
-indicates to suppress the val attribute in each option element within
-the optgroup.
-
-See the discussion on optgroup at W3C
-(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
-for details.
-
-=item 6.
-
-An optional sixth parameter (-attributes) is provided to assign
-any of the common HTML attributes to an individual menu item. It's
-a pointer to a hash relating menu values to another
-hash with the attribute's name as the key and the
-attribute's value as the value.
-
-=back
-
-=head2 CREATING A SCROLLING LIST
-
- print scrolling_list('list_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
- -or-
-
- print scrolling_list('list_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],5,'true',
- \%labels,%attributes);
-
- -or-
-
- print scrolling_list(-name=>'list_name',
- -values=>['eenie','meenie','minie','moe'],
- -default=>['eenie','moe'],
- -size=>5,
- -multiple=>'true',
- -labels=>\%labels,
- -attributes=>\%attributes);
-
-scrolling_list() creates a scrolling list.
-
-B<Parameters:>
-
-=over 4
-
-=item 1.
-
-The first and second arguments are the list name (-name) and values
-(-values). As in the popup menu, the second argument should be an
-array reference.
-
-=item 2.
-
-The optional third argument (-default) can be either a reference to a
-list containing the values to be selected by default, or can be a
-single value to select. If this argument is missing or undefined,
-then nothing is selected when the list first appears. In the named
-parameter version, you can use the synonym "-defaults" for this
-parameter.
-
-=item 3.
-
-The optional fourth argument is the size of the list (-size).
-
-=item 4.
-
-The optional fifth argument can be set to true to allow multiple
-simultaneous selections (-multiple). Otherwise only one selection
-will be allowed at a time.
-
-=item 5.
-
-The optional sixth argument is a pointer to a hash
-containing long user-visible labels for the list items (-labels).
-If not provided, the values will be displayed.
-
-=item 6.
-
-The optional sixth parameter (-attributes) is provided to assign
-any of the common HTML attributes to an individual menu item. It's
-a pointer to a hash relating menu values to another
-hash with the attribute's name as the key and the
-attribute's value as the value.
-
-When this form is processed, all selected list items will be returned as
-a list under the parameter name 'list_name'. The values of the
-selected items can be retrieved with:
-
- @selected = param('list_name');
-
-=back
-
-=head2 CREATING A GROUP OF RELATED CHECKBOXES
-
- print checkbox_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -default=>['eenie','moe'],
- -linebreak=>'true',
- -disabled => ['moe'],
- -labels=>\%labels,
- -attributes=>\%attributes);
-
- print checkbox_group('group_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],'true',\%labels,
- {'moe'=>{'class'=>'red'}});
-
- HTML3-COMPATIBLE BROWSERS ONLY:
-
- print checkbox_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -rows=2,-columns=>2);
-
-
-checkbox_group() creates a list of checkboxes that are related
-by the same name.
-
-B<Parameters:>
-
-=over 4
-
-=item 1.
-
-The first and second arguments are the checkbox name and values,
-respectively (-name and -values). As in the popup menu, the second
-argument should be an array reference. These values are used for the
-user-readable labels printed next to the checkboxes as well as for the
-values passed to your script in the query string.
-
-=item 2.
-
-The optional third argument (-default) can be either a reference to a
-list containing the values to be checked by default, or can be a
-single value to checked. If this argument is missing or undefined,
-then nothing is selected when the list first appears.
-
-=item 3.
-
-The optional fourth argument (-linebreak) can be set to true to place
-line breaks between the checkboxes so that they appear as a vertical
-list. Otherwise, they will be strung together on a horizontal line.
-
-=back
-
-The optional B<-labels> argument is a pointer to a hash
-relating the checkbox values to the user-visible labels that will be
-printed next to them. If not provided, the values will be used as the
-default.
-
-
-The optional parameters B<-rows>, and B<-columns> cause
-checkbox_group() to return an HTML3 compatible table containing the
-checkbox group formatted with the specified number of rows and
-columns. You can provide just the -columns parameter if you wish;
-checkbox_group will calculate the correct number of rows for you.
-
-The option B<-disabled> takes an array of checkbox values and disables
-them by greying them out (this may not be supported by all browsers).
-
-The optional B<-attributes> argument is provided to assign any of the
-common HTML attributes to an individual menu item. It's a pointer to
-a hash relating menu values to another hash
-with the attribute's name as the key and the attribute's value as the
-value.
-
-The optional B<-tabindex> argument can be used to control the order in which
-radio buttons receive focus when the user presses the tab button. If
-passed a scalar numeric value, the first element in the group will
-receive this tab index and subsequent elements will be incremented by
-one. If given a reference to an array of radio button values, then
-the indexes will be jiggered so that the order specified in the array
-will correspond to the tab order. You can also pass a reference to a
-hash in which the hash keys are the radio button values and the values
-are the tab indexes of each button. Examples:
-
- -tabindex => 100 # this group starts at index 100 and counts up
- -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
- -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
-
-The optional B<-labelattributes> argument will contain attributes
-attached to the <label> element that surrounds each button.
-
-When the form is processed, all checked boxes will be returned as
-a list under the parameter name 'group_name'. The values of the
-"on" checkboxes can be retrieved with:
-
- @turned_on = param('group_name');
-
-The value returned by checkbox_group() is actually an array of button
-elements. You can capture them and use them within tables, lists,
-or in other creative ways:
-
- @h = checkbox_group(-name=>'group_name',-values=>\@values);
- &use_in_creative_way(@h);
-
-=head2 CREATING A STANDALONE CHECKBOX
-
- print checkbox(-name=>'checkbox_name',
- -checked=>1,
- -value=>'ON',
- -label=>'CLICK ME');
-
- -or-
-
- print checkbox('checkbox_name','checked','ON','CLICK ME');
-
-checkbox() is used to create an isolated checkbox that isn't logically
-related to any others.
-
-B<Parameters:>
-
-=over 4
-
-=item 1.
-
-The first parameter is the required name for the checkbox (-name). It
-will also be used for the user-readable label printed next to the
-checkbox.
-
-=item 2.
-
-The optional second parameter (-checked) specifies that the checkbox
-is turned on by default. Synonyms are -selected and -on.
-
-=item 3.
-
-The optional third parameter (-value) specifies the value of the
-checkbox when it is checked. If not provided, the word "on" is
-assumed.
-
-=item 4.
-
-The optional fourth parameter (-label) is the user-readable label to
-be attached to the checkbox. If not provided, the checkbox name is
-used.
-
-=back
-
-The value of the checkbox can be retrieved using:
-
- $turned_on = param('checkbox_name');
-
-=head2 CREATING A RADIO BUTTON GROUP
-
- print radio_group(-name=>'group_name',
- -values=>['eenie','meenie','minie'],
- -default=>'meenie',
- -linebreak=>'true',
- -labels=>\%labels,
- -attributes=>\%attributes);
-
- -or-
-
- print radio_group('group_name',['eenie','meenie','minie'],
- 'meenie','true',\%labels,\%attributes);
-
-
- HTML3-COMPATIBLE BROWSERS ONLY:
-
- print radio_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -rows=2,-columns=>2);
-
-radio_group() creates a set of logically-related radio buttons
-(turning one member of the group on turns the others off)
-
-B<Parameters:>
-
-=over 4
-
-=item 1.
-
-The first argument is the name of the group and is required (-name).
-
-=item 2.
-
-The second argument (-values) is the list of values for the radio
-buttons. The values and the labels that appear on the page are
-identical. Pass an array I<reference> in the second argument, either
-using an anonymous array, as shown, or by referencing a named array as
-in "\@foo".
-
-=item 3.
-
-The optional third parameter (-default) is the name of the default
-button to turn on. If not specified, the first item will be the
-default. You can provide a nonexistent button name, such as "-" to
-start up with no buttons selected.
-
-=item 4.
-
-The optional fourth parameter (-linebreak) can be set to 'true' to put
-line breaks between the buttons, creating a vertical list.
-
-=item 5.
-
-The optional fifth parameter (-labels) is a pointer to an associative
-array relating the radio button values to user-visible labels to be
-used in the display. If not provided, the values themselves are
-displayed.
-
-=back
-
-All modern browsers can take advantage of the optional parameters
-B<-rows>, and B<-columns>. These parameters cause radio_group() to
-return an HTML3 compatible table containing the radio group formatted
-with the specified number of rows and columns. You can provide just
-the -columns parameter if you wish; radio_group will calculate the
-correct number of rows for you.
-
-To include row and column headings in the returned table, you
-can use the B<-rowheaders> and B<-colheaders> parameters. Both
-of these accept a pointer to an array of headings to use.
-The headings are just decorative. They don't reorganize the
-interpretation of the radio buttons -- they're still a single named
-unit.
-
-The optional B<-tabindex> argument can be used to control the order in which
-radio buttons receive focus when the user presses the tab button. If
-passed a scalar numeric value, the first element in the group will
-receive this tab index and subsequent elements will be incremented by
-one. If given a reference to an array of radio button values, then
-the indexes will be jiggered so that the order specified in the array
-will correspond to the tab order. You can also pass a reference to a
-hash in which the hash keys are the radio button values and the values
-are the tab indexes of each button. Examples:
-
- -tabindex => 100 # this group starts at index 100 and counts up
- -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
- -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
-
-
-The optional B<-attributes> argument is provided to assign any of the
-common HTML attributes to an individual menu item. It's a pointer to
-a hash relating menu values to another hash
-with the attribute's name as the key and the attribute's value as the
-value.
-
-The optional B<-labelattributes> argument will contain attributes
-attached to the <label> element that surrounds each button.
-
-When the form is processed, the selected radio button can
-be retrieved using:
-
- $which_radio_button = param('group_name');
-
-The value returned by radio_group() is actually an array of button
-elements. You can capture them and use them within tables, lists,
-or in other creative ways:
-
- @h = radio_group(-name=>'group_name',-values=>\@values);
- &use_in_creative_way(@h);
-
-=head2 CREATING A SUBMIT BUTTON
-
- print submit(-name=>'button_name',
- -value=>'value');
-
- -or-
-
- print submit('button_name','value');
-
-submit() will create the query submission button. Every form
-should have one of these.
-
-B<Parameters:>
-
-=over 4
-
-=item 1.
-
-The first argument (-name) is optional. You can give the button a
-name if you have several submission buttons in your form and you want
-to distinguish between them.
-
-=item 2.
-
-The second argument (-value) is also optional. This gives the button
-a value that will be passed to your script in the query string. The
-name will also be used as the user-visible label.
-
-=item 3.
-
-You can use -label as an alias for -value. I always get confused
-about which of -name and -value changes the user-visible label on the
-button.
-
-=back
-
-You can figure out which button was pressed by using different
-values for each one:
-
- $which_one = param('button_name');
-
-=head2 CREATING A RESET BUTTON
-
- print reset
-
-reset() creates the "reset" button. Note that it restores the
-form to its value from the last time the script was called,
-NOT necessarily to the defaults.
-
-Note that this conflicts with the Perl reset() built-in. Use
-CORE::reset() to get the original reset function.
-
-=head2 CREATING A DEFAULT BUTTON
-
- print defaults('button_label')
-
-defaults() creates a button that, when invoked, will cause the
-form to be completely reset to its defaults, wiping out all the
-changes the user ever made.
-
-=head2 CREATING A HIDDEN FIELD
-
- print hidden(-name=>'hidden_name',
- -default=>['value1','value2'...]);
-
- -or-
-
- print hidden('hidden_name','value1','value2'...);
-
-hidden() produces a text field that can't be seen by the user. It
-is useful for passing state variable information from one invocation
-of the script to the next.
-
-B<Parameters:>
-
-=over 4
-
-=item 1.
-
-The first argument is required and specifies the name of this
-field (-name).
-
-=item 2.
-
-The second argument is also required and specifies its value
-(-default). In the named parameter style of calling, you can provide
-a single value here or a reference to a whole list
-
-=back
-
-Fetch the value of a hidden field this way:
-
- $hidden_value = param('hidden_name');
-
-Note, that just like all the other form elements, the value of a
-hidden field is "sticky". If you want to replace a hidden field with
-some other values after the script has been called once you'll have to
-do it manually:
-
- param('hidden_name','new','values','here');
-
-=head2 CREATING A CLICKABLE IMAGE BUTTON
-
- print image_button(-name=>'button_name',
- -src=>'/source/URL',
- -align=>'MIDDLE');
-
- -or-
-
- print image_button('button_name','/source/URL','MIDDLE');
-
-image_button() produces a clickable image. When it's clicked on the
-position of the click is returned to your script as "button_name.x"
-and "button_name.y", where "button_name" is the name you've assigned
-to it.
-
-B<Parameters:>
-
-=over 4
-
-=item 1.
-
-The first argument (-name) is required and specifies the name of this
-field.
-
-=item 2.
-
-The second argument (-src) is also required and specifies the URL
-
-=item 3.
-
-The third option (-align, optional) is an alignment type, and may be
-TOP, BOTTOM or MIDDLE
-
-=back
-
-Fetch the value of the button this way:
- $x = param('button_name.x');
- $y = param('button_name.y');
-
-=head2 CREATING A JAVASCRIPT ACTION BUTTON
-
- print button(-name=>'button_name',
- -value=>'user visible label',
- -onClick=>"do_something()");
-
- -or-
-
- print button('button_name',"user visible value","do_something()");
-
-button() produces an C<< <input> >> tag with C<type="button">. When it's
-pressed the fragment of JavaScript code pointed to by the B<-onClick> parameter
-will be executed.
-
-=head1 HTTP COOKIES
-
-Browsers support a so-called "cookie" designed to help maintain state
-within a browser session. CGI.pm has several methods that support
-cookies.
-
-A cookie is a name=value pair much like the named parameters in a CGI
-query string. CGI scripts create one or more cookies and send
-them to the browser in the HTTP header. The browser maintains a list
-of cookies that belong to a particular Web server, and returns them
-to the CGI script during subsequent interactions.
-
-In addition to the required name=value pair, each cookie has several
-optional attributes:
-
-=over 4
-
-=item 1. an expiration time
-
-This is a time/date string (in a special GMT format) that indicates
-when a cookie expires. The cookie will be saved and returned to your
-script until this expiration date is reached if the user exits
-the browser and restarts it. If an expiration date isn't specified, the cookie
-will remain active until the user quits the browser.
-
-=item 2. a domain
-
-This is a partial or complete domain name for which the cookie is
-valid. The browser will return the cookie to any host that matches
-the partial domain name. For example, if you specify a domain name
-of ".capricorn.com", then the browser will return the cookie to
-Web servers running on any of the machines "www.capricorn.com",
-"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
-must contain at least two periods to prevent attempts to match
-on top level domains like ".edu". If no domain is specified, then
-the browser will only return the cookie to servers on the host the
-cookie originated from.
-
-=item 3. a path
-
-If you provide a cookie path attribute, the browser will check it
-against your script's URL before returning the cookie. For example,
-if you specify the path "/cgi-bin", then the cookie will be returned
-to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
-and "/cgi-bin/customer_service/complain.pl", but not to the script
-"/cgi-private/site_admin.pl". By default, path is set to "/", which
-causes the cookie to be sent to any CGI script on your site.
-
-=item 4. a "secure" flag
-
-If the "secure" attribute is set, the cookie will only be sent to your
-script if the CGI request is occurring on a secure channel, such as SSL.
-
-=back
-
-The interface to HTTP cookies is the B<cookie()> method:
-
- $cookie = cookie(-name=>'sessionID',
- -value=>'xyzzy',
- -expires=>'+1h',
- -path=>'/cgi-bin/database',
- -domain=>'.capricorn.org',
- -secure=>1);
- print header(-cookie=>$cookie);
-
-B<cookie()> creates a new cookie. Its parameters include:
-
-=over 4
-
-=item B<-name>
-
-The name of the cookie (required). This can be any string at all.
-Although browsers limit their cookie names to non-whitespace
-alphanumeric characters, CGI.pm removes this restriction by escaping
-and unescaping cookies behind the scenes.
-
-=item B<-value>
-
-The value of the cookie. This can be any scalar value,
-array reference, or even hash reference. For example,
-you can store an entire hash into a cookie this way:
-
- $cookie=cookie(-name=>'family information',
- -value=>\%childrens_ages);
-
-=item B<-path>
-
-The optional partial path for which this cookie will be valid, as described
-above.
-
-=item B<-domain>
-
-The optional partial domain for which this cookie will be valid, as described
-above.
-
-=item B<-expires>
-
-The optional expiration date for this cookie. The format is as described
-in the section on the B<header()> method:
-
- "+1h" one hour from now
-
-=item B<-secure>
-
-If set to true, this cookie will only be used within a secure
-SSL session.
-
-=back
-
-The cookie created by cookie() must be incorporated into the HTTP
-header within the string returned by the header() method:
-
- use CGI ':standard';
- print header(-cookie=>$my_cookie);
-
-To create multiple cookies, give header() an array reference:
-
- $cookie1 = cookie(-name=>'riddle_name',
- -value=>"The Sphynx's Question");
- $cookie2 = cookie(-name=>'answers',
- -value=>\%answers);
- print header(-cookie=>[$cookie1,$cookie2]);
-
-To retrieve a cookie, request it by name by calling cookie() method
-without the B<-value> parameter. This example uses the object-oriented
-form:
-
- use CGI;
- $query = CGI->new;
- $riddle = $query->cookie('riddle_name');
- %answers = $query->cookie('answers');
-
-Cookies created with a single scalar value, such as the "riddle_name"
-cookie, will be returned in that form. Cookies with array and hash
-values can also be retrieved.
-
-The cookie and CGI namespaces are separate. If you have a parameter
-named 'answers' and a cookie named 'answers', the values retrieved by
-param() and cookie() are independent of each other. However, it's
-simple to turn a CGI parameter into a cookie, and vice-versa:
-
- # turn a CGI parameter into a cookie
- $c=cookie(-name=>'answers',-value=>[param('answers')]);
- # vice-versa
- param(-name=>'answers',-value=>[cookie('answers')]);
-
-If you call cookie() without any parameters, it will return a list of
-the names of all cookies passed to your script:
-
- @cookies = cookie();
-
-See the B<cookie.cgi> example script for some ideas on how to use
-cookies effectively.
-
-=head1 WORKING WITH FRAMES
-
-It's possible for CGI.pm scripts to write into several browser panels
-and windows using the HTML 4 frame mechanism. There are three
-techniques for defining new frames programmatically:
-
-=over 4
-
-=item 1. Create a <Frameset> document
-
-After writing out the HTTP header, instead of creating a standard
-HTML document using the start_html() call, create a <frameset>
-document that defines the frames on the page. Specify your script(s)
-(with appropriate parameters) as the SRC for each of the frames.
-
-There is no specific support for creating <frameset> sections
-in CGI.pm, but the HTML is very simple to write.
-
-=item 2. Specify the destination for the document in the HTTP header
-
-You may provide a B<-target> parameter to the header() method:
-
- print header(-target=>'ResultsWindow');
-
-This will tell the browser to load the output of your script into the
-frame named "ResultsWindow". If a frame of that name doesn't already
-exist, the browser will pop up a new window and load your script's
-document into that. There are a number of magic names that you can
-use for targets. See the HTML C<< <frame> >> documentation for details.
-
-=item 3. Specify the destination for the document in the <form> tag
-
-You can specify the frame to load in the FORM tag itself. With
-CGI.pm it looks like this:
-
- print start_form(-target=>'ResultsWindow');
-
-When your script is reinvoked by the form, its output will be loaded
-into the frame named "ResultsWindow". If one doesn't already exist
-a new window will be created.
-
-=back
-
-The script "frameset.cgi" in the examples directory shows one way to
-create pages in which the fill-out form and the response live in
-side-by-side frames.
-
-=head1 SUPPORT FOR JAVASCRIPT
-
-The usual way to use JavaScript is to define a set of functions in a
-<SCRIPT> block inside the HTML header and then to register event
-handlers in the various elements of the page. Events include such
-things as the mouse passing over a form element, a button being
-clicked, the contents of a text field changing, or a form being
-submitted. When an event occurs that involves an element that has
-registered an event handler, its associated JavaScript code gets
-called.
-
-The elements that can register event handlers include the <BODY> of an
-HTML document, hypertext links, all the various elements of a fill-out
-form, and the form itself. There are a large number of events, and
-each applies only to the elements for which it is relevant. Here is a
-partial list:
-
-=over 4
-
-=item B<onLoad>
-
-The browser is loading the current document. Valid in:
-
- + The HTML <BODY> section only.
-
-=item B<onUnload>
-
-The browser is closing the current page or frame. Valid for:
-
- + The HTML <BODY> section only.
-
-=item B<onSubmit>
-
-The user has pressed the submit button of a form. This event happens
-just before the form is submitted, and your function can return a
-value of false in order to abort the submission. Valid for:
-
- + Forms only.
-
-=item B<onClick>
-
-The mouse has clicked on an item in a fill-out form. Valid for:
-
- + Buttons (including submit, reset, and image buttons)
- + Checkboxes
- + Radio buttons
-
-=item B<onChange>
-
-The user has changed the contents of a field. Valid for:
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=item B<onFocus>
-
-The user has selected a field to work with. Valid for:
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=item B<onBlur>
-
-The user has deselected a field (gone to work somewhere else). Valid
-for:
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=item B<onSelect>
-
-The user has changed the part of a text field that is selected. Valid
-for:
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
-
-=item B<onMouseOver>
-
-The mouse has moved over an element.
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=item B<onMouseOut>
-
-The mouse has moved off an element.
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=back
-
-In order to register a JavaScript event handler with an HTML element,
-just use the event name as a parameter when you call the corresponding
-CGI method. For example, to have your validateAge() JavaScript code
-executed every time the textfield named "age" changes, generate the
-field like this:
-
- print textfield(-name=>'age',-onChange=>"validateAge(this)");
-
-This example assumes that you've already declared the validateAge()
-function by incorporating it into a <SCRIPT> block. The CGI.pm
-start_html() method provides a convenient way to create this section.
-
-Similarly, you can create a form that checks itself over for
-consistency and alerts the user if some essential value is missing by
-creating it this way:
- print start_form(-onSubmit=>"validateMe(this)");
-
-See the javascript.cgi script for a demonstration of how this all
-works.
-
-
-=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
-
-CGI.pm has limited support for HTML3's cascading style sheets (css).
-To incorporate a stylesheet into your document, pass the
-start_html() method a B<-style> parameter. The value of this
-parameter may be a scalar, in which case it is treated as the source
-URL for the stylesheet, or it may be a hash reference. In the latter
-case you should provide the hash with one or more of B<-src> or
-B<-code>. B<-src> points to a URL where an externally-defined
-stylesheet can be found. B<-code> points to a scalar value to be
-incorporated into a <style> section. Style definitions in B<-code>
-override similarly-named ones in B<-src>, hence the name "cascading."
-
-You may also specify the type of the stylesheet by adding the optional
-B<-type> parameter to the hash pointed to by B<-style>. If not
-specified, the style defaults to 'text/css'.
-
-To refer to a style within the body of your document, add the
-B<-class> parameter to any HTML element:
-
- print h1({-class=>'Fancy'},'Welcome to the Party');
-
-Or define styles on the fly with the B<-style> parameter:
-
- print h1({-style=>'Color: red;'},'Welcome to Hell');
-
-You may also use the new B<span()> element to apply a style to a
-section of text:
-
- print span({-style=>'Color: red;'},
- h1('Welcome to Hell'),
- "Where did that handbasket get to?"
- );
-
-Note that you must import the ":html3" definitions to have the
-B<span()> method available. Here's a quick and dirty example of using
-CSS's. See the CSS specification at
-http://www.w3.org/Style/CSS/ for more information.
-
- use CGI qw/:standard :html3/;
-
- #here's a stylesheet incorporated directly into the page
- $newStyle=<<END;
- <!--
- P.Tip {
- margin-right: 50pt;
- margin-left: 50pt;
- color: red;
- }
- P.Alert {
- font-size: 30pt;
- font-family: sans-serif;
- color: red;
- }
- -->
- END
- print header();
- print start_html( -title=>'CGI with Style',
- -style=>{-src=>'http://www.capricorn.com/style/st1.css',
- -code=>$newStyle}
- );
- print h1('CGI with Style'),
- p({-class=>'Tip'},
- "Better read the cascading style sheet spec before playing with this!"),
- span({-style=>'color: magenta'},
- "Look Mom, no hands!",
- p(),
- "Whooo wee!"
- );
- print end_html;
-
-Pass an array reference to B<-code> or B<-src> in order to incorporate
-multiple stylesheets into your document.
-
-Should you wish to incorporate a verbatim stylesheet that includes
-arbitrary formatting in the header, you may pass a -verbatim tag to
-the -style hash, as follows:
-
-print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
- -src => '/server-common/css/core.css'});
-
-
-This will generate an HTML header that contains this:
-
- <link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
- <style type="text/css">
- @import url("/server-common/css/main.css");
- </style>
-
-Any additional arguments passed in the -style value will be
-incorporated into the <link> tag. For example:
-
- start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
- -media => 'all'});
-
-This will give:
-
- <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
- <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
-
-<p>
-
-To make more complicated <link> tags, use the Link() function
-and pass it to start_html() in the -head argument, as in:
-
- @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
- Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
- print start_html({-head=>\@h})
-
-To create primary and "alternate" stylesheet, use the B<-alternate> option:
-
- start_html(-style=>{-src=>[
- {-src=>'/styles/print.css'},
- {-src=>'/styles/alt.css',-alternate=>1}
- ]
- });
-
-=head1 DEBUGGING
-
-If you are running the script from the command line or in the perl
-debugger, you can pass the script a list of keywords or
-parameter=value pairs on the command line or from standard input (you
-don't have to worry about tricking your script into reading from
-environment variables). You can pass keywords like this:
-
- your_script.pl keyword1 keyword2 keyword3
-
-or this:
-
- your_script.pl keyword1+keyword2+keyword3
-
-or this:
-
- your_script.pl name1=value1 name2=value2
-
-or this:
-
- your_script.pl name1=value1&name2=value2
-
-To turn off this feature, use the -no_debug pragma.
-
-To test the POST method, you may enable full debugging with the -debug
-pragma. This will allow you to feed newline-delimited name=value
-pairs to the script on standard input.
-
-When debugging, you can use quotes and backslashes to escape
-characters in the familiar shell manner, letting you place
-spaces and other funny characters in your parameter=value
-pairs:
-
- your_script.pl "name1='I am a long value'" "name2=two\ words"
-
-Finally, you can set the path info for the script by prefixing the first
-name/value parameter with the path followed by a question mark (?):
-
- your_script.pl /your/path/here?name1=value1&name2=value2
-
-=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
-
-The Dump() method produces a string consisting of all the query's
-name/value pairs formatted nicely as a nested list. This is useful
-for debugging purposes:
-
- print Dump
-
-
-Produces something that looks like:
-
- <ul>
- <li>name1
- <ul>
- <li>value1
- <li>value2
- </ul>
- <li>name2
- <ul>
- <li>value1
- </ul>
- </ul>
-
-As a shortcut, you can interpolate the entire CGI object into a string
-and it will be replaced with the a nice HTML dump shown above:
-
- $query=CGI->new;
- print "<h2>Current Values</h2> $query\n";
-
-=head1 FETCHING ENVIRONMENT VARIABLES
-
-Some of the more useful environment variables can be fetched
-through this interface. The methods are as follows:
-
-=over 4
-
-=item B<Accept()>
-
-Return a list of MIME types that the remote browser accepts. If you
-give this method a single argument corresponding to a MIME type, as in
-Accept('text/html'), it will return a floating point value
-corresponding to the browser's preference for this type from 0.0
-(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
-list are handled correctly.
-
-Note that the capitalization changed between version 2.43 and 2.44 in
-order to avoid conflict with Perl's accept() function.
-
-=item B<raw_cookie()>
-
-Returns the HTTP_COOKIE variable. Cookies have a special format, and
-this method call just returns the raw form (?cookie dough). See
-cookie() for ways of setting and retrieving cooked cookies.
-
-Called with no parameters, raw_cookie() returns the packed cookie
-structure. You can separate it into individual cookies by splitting
-on the character sequence "; ". Called with the name of a cookie,
-retrieves the B<unescaped> form of the cookie. You can use the
-regular cookie() method to get the names, or use the raw_fetch()
-method from the CGI::Cookie module.
-
-=item B<user_agent()>
-
-Returns the HTTP_USER_AGENT variable. If you give
-this method a single argument, it will attempt to
-pattern match on it, allowing you to do something
-like user_agent(Mozilla);
-
-=item B<path_info()>
-
-Returns additional path information from the script URL.
-E.G. fetching /cgi-bin/your_script/additional/stuff will result in
-path_info() returning "/additional/stuff".
-
-NOTE: The Microsoft Internet Information Server
-is broken with respect to additional path information. If
-you use the Perl DLL library, the IIS server will attempt to
-execute the additional path information as a Perl script.
-If you use the ordinary file associations mapping, the
-path information will be present in the environment,
-but incorrect. The best thing to do is to avoid using additional
-path information in CGI scripts destined for use with IIS.
-
-=item B<path_translated()>
-
-As per path_info() but returns the additional
-path information translated into a physical path, e.g.
-"/usr/local/etc/httpd/htdocs/additional/stuff".
-
-The Microsoft IIS is broken with respect to the translated
-path as well.
-
-=item B<remote_host()>
-
-Returns either the remote host name or IP address.
-if the former is unavailable.
-
-=item B<remote_addr()>
-
-Returns the remote host IP address, or
-127.0.0.1 if the address is unavailable.
-
-=item B<script_name()>
-Return the script name as a partial URL, for self-referring
-scripts.
-
-=item B<referer()>
-
-Return the URL of the page the browser was viewing
-prior to fetching your script. Not available for all
-browsers.
-
-=item B<auth_type ()>
-
-Return the authorization/verification method in use for this
-script, if any.
-
-=item B<server_name ()>
-
-Returns the name of the server, usually the machine's host
-name.
-
-=item B<virtual_host ()>
-
-When using virtual hosts, returns the name of the host that
-the browser attempted to contact
-
-=item B<server_port ()>
-
-Return the port that the server is listening on.
-
-=item B<virtual_port ()>
-
-Like server_port() except that it takes virtual hosts into account.
-Use this when running with virtual hosts.
-
-=item B<server_software ()>
-
-Returns the server software and version number.
-
-=item B<remote_user ()>
-
-Return the authorization/verification name used for user
-verification, if this script is protected.
-
-=item B<user_name ()>
-
-Attempt to obtain the remote user's name, using a variety of different
-techniques. This only works with older browsers such as Mosaic.
-Newer browsers do not report the user name for privacy reasons!
-
-=item B<request_method()>
-
-Returns the method used to access your script, usually
-one of 'POST', 'GET' or 'HEAD'.
-
-=item B<content_type()>
-
-Returns the content_type of data submitted in a POST, generally
-multipart/form-data or application/x-www-form-urlencoded
-
-=item B<http()>
-
-Called with no arguments returns the list of HTTP environment
-variables, including such things as HTTP_USER_AGENT,
-HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
-like-named HTTP header fields in the request. Called with the name of
-an HTTP header field, returns its value. Capitalization and the use
-of hyphens versus underscores are not significant.
-
-For example, all three of these examples are equivalent:
-
- $requested_language = http('Accept-language');
- $requested_language = http('Accept_language');
- $requested_language = http('HTTP_ACCEPT_LANGUAGE');
-
-=item B<https()>
-
-The same as I<http()>, but operates on the HTTPS environment variables
-present when the SSL protocol is in effect. Can be used to determine
-whether SSL is turned on.
-
-=back
-
-=head1 USING NPH SCRIPTS
-
-NPH, or "no-parsed-header", scripts bypass the server completely by
-sending the complete HTTP header directly to the browser. This has
-slight performance benefits, but is of most use for taking advantage
-of HTTP extensions that are not directly supported by your server,
-such as server push and PICS headers.
-
-Servers use a variety of conventions for designating CGI scripts as
-NPH. Many Unix servers look at the beginning of the script's name for
-the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
-Internet Information Server, in contrast, try to decide whether a
-program is an NPH script by examining the first line of script output.
-
-
-CGI.pm supports NPH scripts with a special NPH mode. When in this
-mode, CGI.pm will output the necessary extra header information when
-the header() and redirect() methods are
-called.
-
-The Microsoft Internet Information Server requires NPH mode. As of
-version 2.30, CGI.pm will automatically detect when the script is
-running under IIS and put itself into this mode. You do not need to
-do this manually, although it won't hurt anything if you do. However,
-note that if you have applied Service Pack 6, much of the
-functionality of NPH scripts, including the ability to redirect while
-setting a cookie, B<do not work at all> on IIS without a special patch
-from Microsoft. See
-http://web.archive.org/web/20010812012030/http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
-Non-Parsed Headers Stripped From CGI Applications That Have nph-
-Prefix in Name.
-
-=over 4
-
-=item In the B<use> statement
-
-Simply add the "-nph" pragma to the list of symbols to be imported into
-your script:
-
- use CGI qw(:standard -nph)
-
-=item By calling the B<nph()> method:
-
-Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
-
- CGI->nph(1)
-
-=item By using B<-nph> parameters
-
-in the B<header()> and B<redirect()> statements:
-
- print header(-nph=>1);
-
-=back
-
-=head1 Server Push
-
-CGI.pm provides four simple functions for producing multipart
-documents of the type needed to implement server push. These
-functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
-import these into your namespace, you must import the ":push" set.
-You are also advised to put the script into NPH mode and to set $| to
-1 to avoid buffering problems.
-
-Here is a simple script that demonstrates server push:
-
- #!/usr/local/bin/perl
- use CGI qw/:push -nph/;
- $| = 1;
- print multipart_init(-boundary=>'----here we go!');
- for (0 .. 4) {
- print multipart_start(-type=>'text/plain'),
- "The current time is ",scalar(localtime),"\n";
- if ($_ < 4) {
- print multipart_end;
- } else {
- print multipart_final;
- }
- sleep 1;
- }
-
-This script initializes server push by calling B<multipart_init()>.
-It then enters a loop in which it begins a new multipart section by
-calling B<multipart_start()>, prints the current local time,
-and ends a multipart section with B<multipart_end()>. It then sleeps
-a second, and begins again. On the final iteration, it ends the
-multipart section with B<multipart_final()> rather than with
-B<multipart_end()>.
-
-=over 4
-
-=item multipart_init()
-
- multipart_init(-boundary=>$boundary);
-
-Initialize the multipart system. The -boundary argument specifies
-what MIME boundary string to use to separate parts of the document.
-If not provided, CGI.pm chooses a reasonable boundary for you.
-
-=item multipart_start()
-
- multipart_start(-type=>$type)
-
-Start a new part of the multipart document using the specified MIME
-type. If not specified, text/html is assumed.
-
-=item multipart_end()
-
- multipart_end()
-
-End a part. You must remember to call multipart_end() once for each
-multipart_start(), except at the end of the last part of the multipart
-document when multipart_final() should be called instead of multipart_end().
-
-=item multipart_final()
-
- multipart_final()
-
-End all parts. You should call multipart_final() rather than
-multipart_end() at the end of the last part of the multipart document.
-
-=back
-
-Users interested in server push applications should also have a look
-at the CGI::Push module.
-
-=head1 Avoiding Denial of Service Attacks
-
-A potential problem with CGI.pm is that, by default, it attempts to
-process form POSTings no matter how large they are. A wily hacker
-could attack your site by sending a CGI script a huge POST of many
-megabytes. CGI.pm will attempt to read the entire POST into a
-variable, growing hugely in size until it runs out of memory. While
-the script attempts to allocate the memory the system may slow down
-dramatically. This is a form of denial of service attack.
-
-Another possible attack is for the remote user to force CGI.pm to
-accept a huge file upload. CGI.pm will accept the upload and store it
-in a temporary directory even if your script doesn't expect to receive
-an uploaded file. CGI.pm will delete the file automatically when it
-terminates, but in the meantime the remote user may have filled up the
-server's disk space, causing problems for other programs.
-
-The best way to avoid denial of service attacks is to limit the amount
-of memory, CPU time and disk space that CGI scripts can use. Some Web
-servers come with built-in facilities to accomplish this. In other
-cases, you can use the shell I<limit> or I<ulimit>
-commands to put ceilings on CGI resource usage.
-
-
-CGI.pm also has some simple built-in protections against denial of
-service attacks, but you must activate them before you can use them.
-These take the form of two global variables in the CGI name space:
-
-=over 4
-
-=item B<$CGI::POST_MAX>
-
-If set to a non-negative integer, this variable puts a ceiling
-on the size of POSTings, in bytes. If CGI.pm detects a POST
-that is greater than the ceiling, it will immediately exit with an error
-message. This value will affect both ordinary POSTs and
-multipart POSTs, meaning that it limits the maximum size of file
-uploads as well. You should set this to a reasonably high
-value, such as 1 megabyte.
-
-=item B<$CGI::DISABLE_UPLOADS>
-
-If set to a non-zero value, this will disable file uploads
-completely. Other fill-out form values will work as usual.
-
-=back
-
-You can use these variables in either of two ways.
-
-=over 4
-
-=item B<1. On a script-by-script basis>
-
-Set the variable at the top of the script, right after the "use" statement:
-
- use CGI qw/:standard/;
- use CGI::Carp 'fatalsToBrowser';
- $CGI::POST_MAX=1024 * 100; # max 100K posts
- $CGI::DISABLE_UPLOADS = 1; # no uploads
-
-=item B<2. Globally for all scripts>
-
-Open up CGI.pm, find the definitions for $POST_MAX and
-$DISABLE_UPLOADS, and set them to the desired values. You'll
-find them towards the top of the file in a subroutine named
-initialize_globals().
-
-=back
-
-An attempt to send a POST larger than $POST_MAX bytes will cause
-I<param()> to return an empty CGI parameter list. You can test for
-this event by checking I<cgi_error()>, either after you create the CGI
-object or, if you are using the function-oriented interface, call
-<param()> for the first time. If the POST was intercepted, then
-cgi_error() will return the message "413 POST too large".
-
-This error message is actually defined by the HTTP protocol, and is
-designed to be returned to the browser as the CGI script's status
- code. For example:
-
- $uploaded_file = param('upload');
- if (!$uploaded_file && cgi_error()) {
- print header(-status=>cgi_error());
- exit 0;
- }
-
-However it isn't clear that any browser currently knows what to do
-with this status code. It might be better just to create an
-HTML page that warns the user of the problem.
-
-=head1 COMPATIBILITY WITH CGI-LIB.PL
-
-To make it easier to port existing programs that use cgi-lib.pl the
-compatibility routine "ReadParse" is provided. Porting is simple:
-
-OLD VERSION
-
- require "cgi-lib.pl";
- &ReadParse;
- print "The value of the antique is $in{antique}.\n";
-
-NEW VERSION
-
- use CGI;
- CGI::ReadParse();
- print "The value of the antique is $in{antique}.\n";
-
-CGI.pm's ReadParse() routine creates a tied variable named %in,
-which can be accessed to obtain the query variables. Like
-ReadParse, you can also provide your own variable. Infrequently
-used features of ReadParse, such as the creation of @in and $in
-variables, are not supported.
-
-Once you use ReadParse, you can retrieve the query object itself
-this way:
-
- $q = $in{CGI};
- print $q->textfield(-name=>'wow',
- -value=>'does this really work?');
-
-This allows you to start using the more interesting features
-of CGI.pm without rewriting your old scripts from scratch.
-
-An even simpler way to mix cgi-lib calls with CGI.pm calls is to import both the
-C<:cgi-lib> and C<:standard> method:
-
- use CGI qw(:cgi-lib :standard);
- &ReadParse;
- print "The price of your purchase is $in{price}.\n";
- print textfield(-name=>'price', -default=>'$1.99');
-
-=head2 Cgi-lib functions that are available in CGI.pm
-
-In compatibility mode, the following cgi-lib.pl functions are
-available for your use:
-
- ReadParse()
- PrintHeader()
- HtmlTop()
- HtmlBot()
- SplitParam()
- MethGet()
- MethPost()
-
-=head2 Cgi-lib functions that are not available in CGI.pm
-
- * Extended form of ReadParse()
- The extended form of ReadParse() that provides for file upload
- spooling, is not available.
-
- * MyBaseURL()
- This function is not available. Use CGI.pm's url() method instead.
-
- * MyFullURL()
- This function is not available. Use CGI.pm's self_url() method
- instead.
-
- * CgiError(), CgiDie()
- These functions are not supported. Look at CGI::Carp for the way I
- prefer to handle error messages.
-
- * PrintVariables()
- This function is not available. To achieve the same effect,
- just print out the CGI object:
-
- use CGI qw(:standard);
- $q = CGI->new;
- print h1("The Variables Are"),$q;
-
- * PrintEnv()
- This function is not available. You'll have to roll your own if you really need it.
-
-=head1 AUTHOR INFORMATION
-
-The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
-distributed under GPL and the Artistic License 2.0. It is currently
-maintained by Mark Stosberg with help from many contributors.
-
-Address bug reports and comments to: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm
-When sending bug reports, please provide the version of CGI.pm, the version of
-Perl, the name and version of your Web server, and the name and version of the
-operating system you are using. If the problem is even remotely browser
-dependent, please provide information about the affected browsers as well.
-
-=head1 CREDITS
-
-Thanks very much to:
-
-=over 4
-
-=item Matt Heffron (heffron@falstaff.css.beckman.com)
-
-=item James Taylor (james.taylor@srs.gov)
-
-=item Scott Anguish <sanguish@digifix.com>
-
-=item Mike Jewell (mlj3u@virginia.edu)
-
-=item Timothy Shimmin (tes@kbs.citri.edu.au)
-
-=item Joergen Haegg (jh@axis.se)
-
-=item Laurent Delfosse (delfosse@delfosse.com)
-
-=item Richard Resnick (applepi1@aol.com)
-
-=item Craig Bishop (csb@barwonwater.vic.gov.au)
-
-=item Tony Curtis (tc@vcpc.univie.ac.at)
-
-=item Tim Bunce (Tim.Bunce@ig.co.uk)
-
-=item Tom Christiansen (tchrist@convex.com)
-
-=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
-
-=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
-
-=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
-
-=item Stephen Dahmen (joyfire@inxpress.net)
-
-=item Ed Jordan (ed@fidalgo.net)
-
-=item David Alan Pisoni (david@cnation.com)
-
-=item Doug MacEachern (dougm@opengroup.org)
-
-=item Robin Houston (robin@oneworld.org)
-
-=item ...and many many more...
-
-for suggestions and bug fixes.
-
-=back
-
-=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
-
-
- #!/usr/local/bin/perl
-
- use CGI ':standard';
-
- print header;
- print start_html("Example CGI.pm Form");
- print "<h1> Example CGI.pm Form</h1>\n";
- print_prompt();
- do_work();
- print_tail();
- print end_html;
-
- sub print_prompt {
- print start_form;
- print "<em>What's your name?</em><br>";
- print textfield('name');
- print checkbox('Not my real name');
-
- print "<p><em>Where can you find English Sparrows?</em><br>";
- print checkbox_group(
- -name=>'Sparrow locations',
- -values=>[England,France,Spain,Asia,Hoboken],
- -linebreak=>'yes',
- -defaults=>[England,Asia]);
-
- print "<p><em>How far can they fly?</em><br>",
- radio_group(
- -name=>'how far',
- -values=>['10 ft','1 mile','10 miles','real far'],
- -default=>'1 mile');
-
- print "<p><em>What's your favorite color?</em> ";
- print popup_menu(-name=>'Color',
- -values=>['black','brown','red','yellow'],
- -default=>'red');
-
- print hidden('Reference','Monty Python and the Holy Grail');
-
- print "<p><em>What have you got there?</em><br>";
- print scrolling_list(
- -name=>'possessions',
- -values=>['A Coconut','A Grail','An Icon',
- 'A Sword','A Ticket'],
- -size=>5,
- -multiple=>'true');
-
- print "<p><em>Any parting comments?</em><br>";
- print textarea(-name=>'Comments',
- -rows=>10,
- -columns=>50);
-
- print "<p>",reset;
- print submit('Action','Shout');
- print submit('Action','Scream');
- print end_form;
- print "<hr>\n";
- }
-
- sub do_work {
-
- print "<h2>Here are the current settings in this form</h2>";
-
- for my $key (param) {
- print "<strong>$key</strong> -> ";
- my @values = param($key);
- print join(", ",@values),"<br>\n";
- }
- }
-
- sub print_tail {
- print <<END;
- <hr>
- <address>Lincoln D. Stein</address><br>
- <a href="/">Home Page</a>
- END
- }
-
-=head1 BUGS
-
-Please report them.
-
-=head1 SEE ALSO
-
-L<CGI::Carp> - provides a L<Carp> implementation tailored to the CGI environment.
-
-L<CGI::Fast> - supports running CGI applications under FastCGI
-
-L<CGI::Pretty> - pretty prints HTML generated by CGI.pm (with a performance penalty)
-
-=cut
-
+++ /dev/null
-package CGI::Apache;
-use CGI;
-use if $] >= 5.019, 'deprecate';
-
-$VERSION = '1.02';
-
-1;
-__END__
-
-=head1 NAME
-
-CGI::Apache - Backward compatibility module for CGI.pm
-
-=head1 SYNOPSIS
-
-Do not use this module. It is deprecated.
-
-=head1 ABSTRACT
-
-=head1 DESCRIPTION
-
-=head1 AUTHOR INFORMATION
-
-=head1 BUGS
-
-=head1 SEE ALSO
-
-=cut
+++ /dev/null
-package CGI::Carp;
-use if $] >= 5.019, 'deprecate';
-
-=head1 NAME
-
-B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log
-
-=head1 SYNOPSIS
-
- use CGI::Carp;
-
- croak "We're outta here!";
- confess "It was my fault: $!";
- carp "It was your fault!";
- warn "I'm confused";
- die "I'm dying.\n";
-
- use CGI::Carp qw(cluck);
- cluck "I wouldn't do that if I were you";
-
- use CGI::Carp qw(fatalsToBrowser);
- die "Fatal error messages are now sent to browser";
-
-=head1 DESCRIPTION
-
-CGI scripts have a nasty habit of leaving warning messages in the error
-logs that are neither time stamped nor fully identified. Tracking down
-the script that caused the error is a pain. This fixes that. Replace
-the usual
-
- use Carp;
-
-with
-
- use CGI::Carp
-
-The standard warn(), die (), croak(), confess() and carp() calls will
-be replaced with functions that write time-stamped messages to the
-HTTP server error log.
-
-For example:
-
- [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
- [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
- [Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
-
-=head1 REDIRECTING ERROR MESSAGES
-
-By default, error messages are sent to STDERR. Most HTTPD servers
-direct STDERR to the server's error log. Some applications may wish
-to keep private error logs, distinct from the server's error log, or
-they may wish to direct error messages to STDOUT so that the browser
-will receive them.
-
-The C<carpout()> function is provided for this purpose. Since
-carpout() is not exported by default, you must import it explicitly by
-saying
-
- use CGI::Carp qw(carpout);
-
-The carpout() function requires one argument, a reference to an open
-filehandle for writing errors. It should be called in a C<BEGIN>
-block at the top of the CGI application so that compiler errors will
-be caught. Example:
-
- BEGIN {
- use CGI::Carp qw(carpout);
- open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
- die("Unable to open mycgi-log: $!\n");
- carpout(LOG);
- }
-
-carpout() does not handle file locking on the log for you at this
-point. Also, note that carpout() does not work with in-memory file
-handles, although a patch would be welcome to address that.
-
-The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR.
-Some servers, when dealing with CGI scripts, close their connection to
-the browser when the script closes STDOUT and STDERR.
-CGI::Carp::SAVEERR is there to prevent this from happening
-prematurely.
-
-You can pass filehandles to carpout() in a variety of ways. The "correct"
-way according to Tom Christiansen is to pass a reference to a filehandle
-GLOB:
-
- carpout(\*LOG);
-
-This looks weird to mere mortals however, so the following syntaxes are
-accepted as well:
-
- carpout(LOG);
- carpout(main::LOG);
- carpout(main'LOG);
- carpout(\LOG);
- carpout(\'main::LOG');
-
- ... and so on
-
-FileHandle and other objects work as well.
-
-Use of carpout() is not great for performance, so it is recommended
-for debugging purposes or for moderate-use applications. A future
-version of this module may delay redirecting STDERR until one of the
-CGI::Carp methods is called to prevent the performance hit.
-
-=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
-
-If you want to send fatal (die, confess) errors to the browser, import
-the special "fatalsToBrowser" subroutine:
-
- use CGI::Carp qw(fatalsToBrowser);
- die "Bad error here";
-
-Fatal errors will now be echoed to the browser as well as to the log.
-CGI::Carp arranges to send a minimal HTTP header to the browser so
-that even errors that occur in the early compile phase will be seen.
-Nonfatal errors will still be directed to the log file only (unless
-redirected with carpout).
-
-Note that fatalsToBrowser may B<not> work well with mod_perl version 2.0
-and higher.
-
-=head2 Changing the default message
-
-By default, the software error message is followed by a note to
-contact the Webmaster by e-mail with the time and date of the error.
-If this message is not to your liking, you can change it using the
-set_message() routine. This is not imported by default; you should
-import it on the use() line:
-
- use CGI::Carp qw(fatalsToBrowser set_message);
- set_message("It's not a bug, it's a feature!");
-
-You may also pass in a code reference in order to create a custom
-error message. At run time, your code will be called with the text
-of the error message that caused the script to die. Example:
-
- use CGI::Carp qw(fatalsToBrowser set_message);
- BEGIN {
- sub handle_errors {
- my $msg = shift;
- print "<h1>Oh gosh</h1>";
- print "<p>Got an error: $msg</p>";
- }
- set_message(\&handle_errors);
- }
-
-In order to correctly intercept compile-time errors, you should call
-set_message() from within a BEGIN{} block.
-
-=head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS
-
-If fatalsToBrowser in conjunction with set_message does not provide
-you with all of the functionality you need, you can go one step
-further by specifying a function to be executed any time a script
-calls "die", has a syntax error, or dies unexpectedly at runtime
-with a line like "undef->explode();".
-
- use CGI::Carp qw(set_die_handler);
- BEGIN {
- sub handle_errors {
- my $msg = shift;
- print "content-type: text/html\n\n";
- print "<h1>Oh gosh</h1>";
- print "<p>Got an error: $msg</p>";
-
- #proceed to send an email to a system administrator,
- #write a detailed message to the browser and/or a log,
- #etc....
- }
- set_die_handler(\&handle_errors);
- }
-
-Notice that if you use set_die_handler(), you must handle sending
-HTML headers to the browser yourself if you are printing a message.
-
-If you use set_die_handler(), you will most likely interfere with
-the behavior of fatalsToBrowser, so you must use this or that, not
-both.
-
-Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser),
-and there is only one SIG{__DIE__}. This means that if you are
-attempting to set SIG{__DIE__} yourself, you may interfere with
-this module's functionality, or this module may interfere with
-your module's functionality.
-
-=head2 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW
-
-A problem sometimes encountered when using fatalsToBrowser is
-when a C<die()> is done inside an C<eval> body or expression.
-Even though the
-fatalsToBrower support takes precautions to avoid this,
-you still may get the error message printed to STDOUT.
-This may have some undesirable effects when the purpose of doing the
-eval is to determine which of several algorithms is to be used.
-
-By setting C<$CGI::Carp::TO_BROWSER> to 0 you can suppress printing
-the C<die> messages but without all of the complexity of using
-C<set_die_handler>. You can localize this effect to inside C<eval>
-bodies if this is desirable: For example:
-
- eval {
- local $CGI::Carp::TO_BROWSER = 0;
- die "Fatal error messages not sent browser"
- }
- # $@ will contain error message
-
-
-=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
-
-It is also possible to make non-fatal errors appear as HTML comments
-embedded in the output of your program. To enable this feature,
-export the new "warningsToBrowser" subroutine. Since sending warnings
-to the browser before the HTTP headers have been sent would cause an
-error, any warnings are stored in an internal buffer until you call
-the warningsToBrowser() subroutine with a true argument:
-
- use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
- use CGI qw(:standard);
- print header();
- warningsToBrowser(1);
-
-You may also give a false argument to warningsToBrowser() to prevent
-warnings from being sent to the browser while you are printing some
-content where HTML comments are not allowed:
-
- warningsToBrowser(0); # disable warnings
- print "<script type=\"text/javascript\"><!--\n";
- print_some_javascript_code();
- print "//--></script>\n";
- warningsToBrowser(1); # re-enable warnings
-
-Note: In this respect warningsToBrowser() differs fundamentally from
-fatalsToBrowser(), which you should never call yourself!
-
-=head1 OVERRIDING THE NAME OF THE PROGRAM
-
-CGI::Carp includes the name of the program that generated the error or
-warning in the messages written to the log and the browser window.
-Sometimes, Perl can get confused about what the actual name of the
-executed program was. In these cases, you can override the program
-name that CGI::Carp will use for all messages.
-
-The quick way to do that is to tell CGI::Carp the name of the program
-in its use statement. You can do that by adding
-"name=cgi_carp_log_name" to your "use" statement. For example:
-
- use CGI::Carp qw(name=cgi_carp_log_name);
-
-. If you want to change the program name partway through the program,
-you can use the C<set_progname()> function instead. It is not
-exported by default, you must import it explicitly by saying
-
- use CGI::Carp qw(set_progname);
-
-Once you've done that, you can change the logged name of the program
-at any time by calling
-
- set_progname(new_program_name);
-
-You can set the program back to the default by calling
-
- set_progname(undef);
-
-Note that this override doesn't happen until after the program has
-compiled, so any compile-time errors will still show up with the
-non-overridden program name
-
-=head1 CHANGE LOG
-
-3.51 Added $CGI::Carp::TO_BROWSER
-
-1.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp
- not behaving correctly in an eval() context.
-
-1.05 carpout() added and minor corrections by Marc Hedlund
- <hedlund@best.com> on 11/26/95.
-
-1.06 fatalsToBrowser() no longer aborts for fatal errors within
- eval() statements.
-
-1.08 set_message() added and carpout() expanded to allow for FileHandle
- objects.
-
-1.09 set_message() now allows users to pass a code REFERENCE for
- really custom error messages. croak and carp are now
- exported by default. Thanks to Gunther Birznieks for the
- patches.
-
-1.10 Patch from Chris Dean (ctdean@cogit.com) to allow
- module to run correctly under mod_perl.
-
-1.11 Changed order of > and < escapes.
-
-1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning.
-
-1.13 Added cluck() to make the module orthogonal with Carp.
- More mod_perl related fixes.
-
-1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added
- warningsToBrowser(). Replaced <CODE> tags with <PRE> in
- fatalsToBrowser() output.
-
-1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern
- (hack alert!) in order to accommodate various combinations of Perl and
- mod_perl.
-
-1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
- for overriding program name.
-
-1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the
- former isn't working in some people's hands. There is no such thing
- as reliable exception handling in Perl.
-
-1.27 Replaced tell STDOUT with bytes=tell STDOUT.
-
-=head1 AUTHORS
-
-Copyright 1995-2002, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<Carp>, L<CGI::Base>, L<CGI::BasePlus>, L<CGI::Request>,
-L<CGI::MiniSvr>, L<CGI::Form>, L<CGI::Response>.
-
-=cut
-
-require 5.000;
-use Exporter;
-#use Carp;
-BEGIN {
- require Carp;
- *CORE::GLOBAL::die = \&CGI::Carp::die;
-}
-
-use File::Spec;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_die_handler set_progname cluck ^name= die);
-
-$main::SIG{__WARN__}=\&CGI::Carp::warn;
-
-$CGI::Carp::VERSION = '3.64';
-$CGI::Carp::CUSTOM_MSG = undef;
-$CGI::Carp::DIE_HANDLER = undef;
-$CGI::Carp::TO_BROWSER = 1;
-
-
-# fancy import routine detects and handles 'errorWrap' specially.
-sub import {
- my $pkg = shift;
- my(%routines);
- my(@name);
- if (@name=grep(/^name=/,@_))
- {
- my($n) = (split(/=/,$name[0]))[1];
- set_progname($n);
- @_=grep(!/^name=/,@_);
- }
-
- grep($routines{$_}++,@_,@EXPORT);
- $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
- $WARN++ if $routines{'warningsToBrowser'};
- my($oldlevel) = $Exporter::ExportLevel;
- $Exporter::ExportLevel = 1;
- Exporter::import($pkg,keys %routines);
- $Exporter::ExportLevel = $oldlevel;
- $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
-# $pkg->export('CORE::GLOBAL','die');
-}
-
-# These are the originals
-sub realwarn { CORE::warn(@_); }
-sub realdie { CORE::die(@_); }
-
-sub id {
- my $level = shift;
- my($pack,$file,$line,$sub) = caller($level);
- my($dev,$dirs,$id) = File::Spec->splitpath($file);
- return ($file,$line,$id);
-}
-
-sub stamp {
- my $time = scalar(localtime);
- my $frame = 0;
- my ($id,$pack,$file,$dev,$dirs);
- if (defined($CGI::Carp::PROGNAME)) {
- $id = $CGI::Carp::PROGNAME;
- } else {
- do {
- $id = $file;
- ($pack,$file) = caller($frame++);
- } until !$file;
- }
- ($dev,$dirs,$id) = File::Spec->splitpath($id);
- return "[$time] $id: ";
-}
-
-sub set_progname {
- $CGI::Carp::PROGNAME = shift;
- return $CGI::Carp::PROGNAME;
-}
-
-
-sub warn {
- my $message = shift;
- my($file,$line,$id) = id(1);
- $message .= " at $file line $line.\n" unless $message=~/\n$/;
- _warn($message) if $WARN;
- my $stamp = stamp;
- $message=~s/^/$stamp/gm;
- realwarn $message;
-}
-
-sub _warn {
- my $msg = shift;
- if ($EMIT_WARNINGS) {
- # We need to mangle the message a bit to make it a valid HTML
- # comment. This is done by substituting similar-looking ISO
- # 8859-1 characters for <, > and -. This is a hack.
- $msg =~ tr/<>-/\253\273\255/;
- chomp $msg;
- print STDOUT "<!-- warning: $msg -->\n";
- } else {
- push @WARNINGS, $msg;
- }
-}
-
-
-# The mod_perl package Apache::Registry loads CGI programs by calling
-# eval. These evals don't count when looking at the stack backtrace.
-sub _longmess {
- my $message = Carp::longmess();
- $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s
- if exists $ENV{MOD_PERL};
- return $message;
-}
-
-sub ineval {
- (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m
-}
-
-sub die {
- # if no argument is passed, propagate $@ like
- # the real die
- my ($arg,@rest) = @_ ? @_
- : $@ ? "$@\t...propagated"
- : "Died"
- ;
-
- &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
-
- # the "$arg" is done on purpose!
- # if called as die( $object, 'string' ),
- # all is stringified, just like with
- # the real 'die'
- $arg = join '' => "$arg", @rest if @rest;
-
- my($file,$line,$id) = id(1);
-
- $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/;
-
- realdie $arg if ineval();
- &fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER);
-
- $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
-
- $arg .= "\n" unless $arg =~ /\n$/;
-
- realdie $arg;
-}
-
-sub set_message {
- $CGI::Carp::CUSTOM_MSG = shift;
- return $CGI::Carp::CUSTOM_MSG;
-}
-
-sub set_die_handler {
-
- my ($handler) = shift;
-
- #setting SIG{__DIE__} here is necessary to catch runtime
- #errors which are not called by literally saying "die",
- #such as the line "undef->explode();". however, doing this
- #will interfere with fatalsToBrowser, which also sets
- #SIG{__DIE__} in the import() function above (or the
- #import() function above may interfere with this). for
- #this reason, you should choose to either set the die
- #handler here, or use fatalsToBrowser, not both.
- $main::SIG{__DIE__} = $handler;
-
- $CGI::Carp::DIE_HANDLER = $handler;
-
- return $CGI::Carp::DIE_HANDLER;
-}
-
-sub confess { CGI::Carp::die Carp::longmess @_; }
-sub croak { CGI::Carp::die Carp::shortmess @_; }
-sub carp { CGI::Carp::warn Carp::shortmess @_; }
-sub cluck { CGI::Carp::warn Carp::longmess @_; }
-
-# We have to be ready to accept a filehandle as a reference
-# or a string.
-sub carpout {
- my($in) = @_;
- my($no) = fileno(to_filehandle($in));
- realdie("Invalid filehandle $in\n") unless defined $no;
-
- open(SAVEERR, ">&STDERR");
- open(STDERR, ">&$no") or
- ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
-}
-
-sub warningsToBrowser {
- $EMIT_WARNINGS = @_ ? shift : 1;
- _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
-}
-
-# headers
-sub fatalsToBrowser {
- my $msg = shift;
-
- $msg = "$msg" if ref $msg;
-
- $msg=~s/&/&/g;
- $msg=~s/>/>/g;
- $msg=~s/</</g;
- $msg=~s/"/"/g;
-
- my($wm) = $ENV{SERVER_ADMIN} ?
- qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
- "this site's webmaster";
- my ($outer_message) = <<END;
-For help, please send mail to $wm, giving this error message
-and the time and date of the error.
-END
- ;
- my $mod_perl = exists $ENV{MOD_PERL};
-
- if ($CUSTOM_MSG) {
- if (ref($CUSTOM_MSG) eq 'CODE') {
- print STDOUT "Content-type: text/html\n\n"
- unless $mod_perl;
- eval {
- &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
- };
- if ($@) { print STDERR q(error while executing the error handler: $@); }
-
- return;
- } else {
- $outer_message = $CUSTOM_MSG;
- }
- }
-
- my $mess = <<END;
-<h1>Software error:</h1>
-<pre>$msg</pre>
-<p>
-$outer_message
-</p>
-END
- ;
-
- if ($mod_perl) {
- my $r;
- if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
- $mod_perl = 2;
- require Apache2::RequestRec;
- require Apache2::RequestIO;
- require Apache2::RequestUtil;
- require APR::Pool;
- require ModPerl::Util;
- require Apache2::Response;
- $r = Apache2::RequestUtil->request;
- }
- else {
- $r = Apache->request;
- }
- # If bytes have already been sent, then
- # we print the message out directly.
- # Otherwise we make a custom error
- # handler to produce the doc for us.
- if ($r->bytes_sent) {
- $r->print($mess);
- $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
- } else {
- # MSIE won't display a custom 500 response unless it is >512 bytes!
- if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
- $mess = "<!-- " . (' ' x 513) . " -->\n$mess";
- }
- $r->custom_response(500,$mess);
- }
- } else {
- my $bytes_written = eval{tell STDOUT};
- if (defined $bytes_written && $bytes_written > 0) {
- print STDOUT $mess;
- }
- else {
- print STDOUT "Status: 500\n";
- print STDOUT "Content-type: text/html\n\n";
- print STDOUT $mess;
- }
- }
-
- warningsToBrowser(1); # emit warnings before dying
-}
-
-# Cut and paste from CGI.pm so that we don't have the overhead of
-# always loading the entire CGI module.
-sub to_filehandle {
- my $thingy = shift;
- return undef unless $thingy;
- return $thingy if UNIVERSAL::isa($thingy,'GLOB');
- return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
- if (!ref($thingy)) {
- my $caller = 1;
- while (my $package = caller($caller++)) {
- my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
- return $tmp if defined(fileno($tmp));
- }
- }
- return undef;
-}
-
-1;
+++ /dev/null
-package CGI::Cookie;
-
-use strict;
-use warnings;
-
-use if $] >= 5.019, 'deprecate';
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995-1999, Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-our $VERSION='1.31';
-
-use CGI::Util qw(rearrange unescape escape);
-use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1;
-
-my $PERLEX = 0;
-# Turn on special checking for ActiveState's PerlEx
-$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
-
-# Turn on special checking for mod_perl
-# PerlEx::DBI tries to fool DBI by setting MOD_PERL
-my $MOD_PERL = 0;
-if (exists $ENV{MOD_PERL} && ! $PERLEX) {
- if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
- $MOD_PERL = 2;
- require Apache2::RequestUtil;
- require APR::Table;
- } else {
- $MOD_PERL = 1;
- require Apache;
- }
-}
-
-# fetch a list of cookies from the environment and
-# return as a hash. the cookies are parsed as normal
-# escaped URL data.
-sub fetch {
- my $class = shift;
- my $raw_cookie = get_raw_cookie(@_) or return;
- return $class->parse($raw_cookie);
-}
-
-# Fetch a list of cookies from the environment or the incoming headers and
-# return as a hash. The cookie values are not unescaped or altered in any way.
- sub raw_fetch {
- my $class = shift;
- my $raw_cookie = get_raw_cookie(@_) or return;
- my %results;
- my($key,$value);
-
- my @pairs = split("[;,] ?",$raw_cookie);
- for my $pair ( @pairs ) {
- $pair =~ s/^\s+|\s+$//g; # trim leading trailing whitespace
- my ( $key, $value ) = split "=", $pair;
-
- $value = defined $value ? $value : '';
- $results{$key} = $value;
- }
- return wantarray ? %results : \%results;
-}
-
-sub get_raw_cookie {
- my $r = shift;
- $r ||= eval { $MOD_PERL == 2 ?
- Apache2::RequestUtil->request() :
- Apache->request } if $MOD_PERL;
-
- return $r->headers_in->{'Cookie'} if $r;
-
- die "Run $r->subprocess_env; before calling fetch()"
- if $MOD_PERL and !exists $ENV{REQUEST_METHOD};
-
- return $ENV{HTTP_COOKIE} || $ENV{COOKIE};
-}
-
-
-sub parse {
- my ($self,$raw_cookie) = @_;
- return wantarray ? () : {} unless $raw_cookie;
-
- my %results;
-
- my @pairs = split("[;,] ?",$raw_cookie);
- for (@pairs) {
- s/^\s+//;
- s/\s+$//;
-
- my($key,$value) = split("=",$_,2);
-
- # Some foreign cookies are not in name=value format, so ignore
- # them.
- next if !defined($value);
- my @values = ();
- if ($value ne '') {
- @values = map unescape($_),split(/[&;]/,$value.'&dmy');
- pop @values;
- }
- $key = unescape($key);
- # A bug in Netscape can cause several cookies with same name to
- # appear. The FIRST one in HTTP_COOKIE is the most recent version.
- $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
- }
- return wantarray ? %results : \%results;
-}
-
-sub new {
- my ( $class, @params ) = @_;
- $class = ref( $class ) || $class;
- # Ignore mod_perl request object--compatibility with Apache::Cookie.
- shift if ref $params[0]
- && eval { $params[0]->isa('Apache::Request::Req') || $params[0]->isa('Apache') };
- my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly )
- = rearrange(
- [
- 'NAME', [ 'VALUE', 'VALUES' ],
- 'PATH', 'DOMAIN',
- 'SECURE', 'EXPIRES',
- 'MAX-AGE','HTTPONLY'
- ],
- @params
- );
- return undef unless defined $name and defined $value;
- my $self = {};
- bless $self, $class;
- $self->name( $name );
- $self->value( $value );
- $path ||= "/";
- $self->path( $path ) if defined $path;
- $self->domain( $domain ) if defined $domain;
- $self->secure( $secure ) if defined $secure;
- $self->expires( $expires ) if defined $expires;
- $self->max_age($expires) if defined $max_age;
- $self->httponly( $httponly ) if defined $httponly;
- return $self;
-}
-
-sub as_string {
- my $self = shift;
- return "" unless $self->name;
-
- no warnings; # some things may be undefined, that's OK.
-
- my $name = escape( $self->name );
- my $value = join "&", map { escape($_) } $self->value;
- my @cookie = ( "$name=$value" );
-
- push @cookie,"domain=".$self->domain if $self->domain;
- push @cookie,"path=".$self->path if $self->path;
- push @cookie,"expires=".$self->expires if $self->expires;
- push @cookie,"max-age=".$self->max_age if $self->max_age;
- push @cookie,"secure" if $self->secure;
- push @cookie,"HttpOnly" if $self->httponly;
-
- return join "; ", @cookie;
-}
-
-sub compare {
- my ( $self, $value ) = @_;
- return "$self" cmp $value;
-}
-
-sub bake {
- my ($self, $r) = @_;
-
- $r ||= eval {
- $MOD_PERL == 2
- ? Apache2::RequestUtil->request()
- : Apache->request
- } if $MOD_PERL;
- if ($r) {
- $r->headers_out->add('Set-Cookie' => $self->as_string);
- } else {
- require CGI;
- print CGI::header(-cookie => $self);
- }
-
-}
-
-# accessors
-sub name {
- my ( $self, $name ) = @_;
- $self->{'name'} = $name if defined $name;
- return $self->{'name'};
-}
-
-sub value {
- my ( $self, $value ) = @_;
- if ( defined $value ) {
- my @values
- = ref $value eq 'ARRAY' ? @$value
- : ref $value eq 'HASH' ? %$value
- : ( $value );
- $self->{'value'} = [@values];
- }
- return wantarray ? @{ $self->{'value'} } : $self->{'value'}->[0];
-}
-
-sub domain {
- my ( $self, $domain ) = @_;
- $self->{'domain'} = lc $domain if defined $domain;
- return $self->{'domain'};
-}
-
-sub secure {
- my ( $self, $secure ) = @_;
- $self->{'secure'} = $secure if defined $secure;
- return $self->{'secure'};
-}
-
-sub expires {
- my ( $self, $expires ) = @_;
- $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
- return $self->{'expires'};
-}
-
-sub max_age {
- my ( $self, $max_age ) = @_;
- $self->{'max-age'} = CGI::Util::expire_calc($max_age)-time() if defined $max_age;
- return $self->{'max-age'};
-}
-
-sub path {
- my ( $self, $path ) = @_;
- $self->{'path'} = $path if defined $path;
- return $self->{'path'};
-}
-
-
-sub httponly { # HttpOnly
- my ( $self, $httponly ) = @_;
- $self->{'httponly'} = $httponly if defined $httponly;
- return $self->{'httponly'};
-}
-
-1;
-
-=head1 NAME
-
-CGI::Cookie - Interface to HTTP Cookies
-
-=head1 SYNOPSIS
-
- use CGI qw/:standard/;
- use CGI::Cookie;
-
- # Create new cookies and send them
- $cookie1 = CGI::Cookie->new(-name=>'ID',-value=>123456);
- $cookie2 = CGI::Cookie->new(-name=>'preferences',
- -value=>{ font => Helvetica,
- size => 12 }
- );
- print header(-cookie=>[$cookie1,$cookie2]);
-
- # fetch existing cookies
- %cookies = CGI::Cookie->fetch;
- $id = $cookies{'ID'}->value;
-
- # create cookies returned from an external source
- %cookies = CGI::Cookie->parse($ENV{COOKIE});
-
-=head1 DESCRIPTION
-
-CGI::Cookie is an interface to HTTP/1.1 cookies, an
-innovation that allows Web servers to store persistent information on
-the browser's side of the connection. Although CGI::Cookie is
-intended to be used in conjunction with CGI.pm (and is in fact used by
-it internally), you can use this module independently.
-
-For full information on cookies see
-
- http://tools.ietf.org/html/rfc2109
- http://tools.ietf.org/html/rfc2965
- http://tools.ietf.org/html/draft-ietf-httpstate-cookie
-
-=head1 USING CGI::Cookie
-
-CGI::Cookie is object oriented. Each cookie object has a name and a
-value. The name is any scalar value. The value is any scalar or
-array value (associative arrays are also allowed). Cookies also have
-several optional attributes, including:
-
-=over 4
-
-=item B<1. expiration date>
-
-The expiration date tells the browser how long to hang on to the
-cookie. If the cookie specifies an expiration date in the future, the
-browser will store the cookie information in a disk file and return it
-to the server every time the user reconnects (until the expiration
-date is reached). If the cookie species an expiration date in the
-past, the browser will remove the cookie from the disk file. If the
-expiration date is not specified, the cookie will persist only until
-the user quits the browser.
-
-=item B<2. domain>
-
-This is a partial or complete domain name for which the cookie is
-valid. The browser will return the cookie to any host that matches
-the partial domain name. For example, if you specify a domain name
-of ".capricorn.com", then the browser will return the cookie to
-Web servers running on any of the machines "www.capricorn.com",
-"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names
-must contain at least two periods to prevent attempts to match
-on top level domains like ".edu". If no domain is specified, then
-the browser will only return the cookie to servers on the host the
-cookie originated from.
-
-=item B<3. path>
-
-If you provide a cookie path attribute, the browser will check it
-against your script's URL before returning the cookie. For example,
-if you specify the path "/cgi-bin", then the cookie will be returned
-to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
-"/cgi-bin/customer_service/complain.pl", but not to the script
-"/cgi-private/site_admin.pl". By default, the path is set to "/", so
-that all scripts at your site will receive the cookie.
-
-=item B<4. secure flag>
-
-If the "secure" attribute is set, the cookie will only be sent to your
-script if the CGI request is occurring on a secure channel, such as SSL.
-
-=item B<5. httponly flag>
-
-If the "httponly" attribute is set, the cookie will only be accessible
-through HTTP Requests. This cookie will be inaccessible via JavaScript
-(to prevent XSS attacks).
-
-This feature is supported by nearly all modern browsers.
-
-See these URLs for more information:
-
- http://msdn.microsoft.com/en-us/library/ms533046.aspx
- http://www.browserscope.org/?category=security&v=top
-
-=back
-
-=head2 Creating New Cookies
-
- my $c = CGI::Cookie->new(-name => 'foo',
- -value => 'bar',
- -expires => '+3M',
- -domain => '.capricorn.com',
- -path => '/cgi-bin/database',
- -secure => 1
- );
-
-Create cookies from scratch with the B<new> method. The B<-name> and
-B<-value> parameters are required. The name must be a scalar value.
-The value can be a scalar, an array reference, or a hash reference.
-(At some point in the future cookies will support one of the Perl
-object serialization protocols for full generality).
-
-B<-expires> accepts any of the relative or absolute date formats
-recognized by CGI.pm, for example "+3M" for three months in the
-future. See CGI.pm's documentation for details.
-
-B<-max-age> accepts the same data formats as B<< -expires >>, but sets a
-relative value instead of an absolute like B<< -expires >>. This is intended to be
-more secure since a clock could be changed to fake an absolute time. In
-practice, as of 2011, C<< -max-age >> still does not enjoy the widespread support
-that C<< -expires >> has. You can set both, and browsers that support
-C<< -max-age >> should ignore the C<< Expires >> header. The drawback
-to this approach is the bit of bandwidth for sending an extra header on each cookie.
-
-B<-domain> points to a domain name or to a fully qualified host name.
-If not specified, the cookie will be returned only to the Web server
-that created it.
-
-B<-path> points to a partial URL on the current server. The cookie
-will be returned to all URLs beginning with the specified path. If
-not specified, it defaults to '/', which returns the cookie to all
-pages at your site.
-
-B<-secure> if set to a true value instructs the browser to return the
-cookie only when a cryptographic protocol is in use.
-
-B<-httponly> if set to a true value, the cookie will not be accessible
-via JavaScript.
-
-For compatibility with Apache::Cookie, you may optionally pass in
-a mod_perl request object as the first argument to C<new()>. It will
-simply be ignored:
-
- my $c = CGI::Cookie->new($r,
- -name => 'foo',
- -value => ['bar','baz']);
-
-=head2 Sending the Cookie to the Browser
-
-The simplest way to send a cookie to the browser is by calling the bake()
-method:
-
- $c->bake;
-
-This will print the Set-Cookie HTTP header to STDOUT using CGI.pm. CGI.pm
-will be loaded for this purpose if it is not already. Otherwise CGI.pm is not
-required or used by this module.
-
-Under mod_perl, pass in an Apache request object:
-
- $c->bake($r);
-
-If you want to set the cookie yourself, Within a CGI script you can send
-a cookie to the browser by creating one or more Set-Cookie: fields in the
-HTTP header. Here is a typical sequence:
-
- my $c = CGI::Cookie->new(-name => 'foo',
- -value => ['bar','baz'],
- -expires => '+3M');
-
- print "Set-Cookie: $c\n";
- print "Content-Type: text/html\n\n";
-
-To send more than one cookie, create several Set-Cookie: fields.
-
-If you are using CGI.pm, you send cookies by providing a -cookie
-argument to the header() method:
-
- print header(-cookie=>$c);
-
-Mod_perl users can set cookies using the request object's header_out()
-method:
-
- $r->headers_out->set('Set-Cookie' => $c);
-
-Internally, Cookie overloads the "" operator to call its as_string()
-method when incorporated into the HTTP header. as_string() turns the
-Cookie's internal representation into an RFC-compliant text
-representation. You may call as_string() yourself if you prefer:
-
- print "Set-Cookie: ",$c->as_string,"\n";
-
-=head2 Recovering Previous Cookies
-
- %cookies = CGI::Cookie->fetch;
-
-B<fetch> returns an associative array consisting of all cookies
-returned by the browser. The keys of the array are the cookie names. You
-can iterate through the cookies this way:
-
- %cookies = CGI::Cookie->fetch;
- for (keys %cookies) {
- do_something($cookies{$_});
- }
-
-In a scalar context, fetch() returns a hash reference, which may be more
-efficient if you are manipulating multiple cookies.
-
-CGI.pm uses the URL escaping methods to save and restore reserved characters
-in its cookies. If you are trying to retrieve a cookie set by a foreign server,
-this escaping method may trip you up. Use raw_fetch() instead, which has the
-same semantics as fetch(), but performs no unescaping.
-
-You may also retrieve cookies that were stored in some external
-form using the parse() class method:
-
- $COOKIES = `cat /usr/tmp/Cookie_stash`;
- %cookies = CGI::Cookie->parse($COOKIES);
-
-If you are in a mod_perl environment, you can save some overhead by
-passing the request object to fetch() like this:
-
- CGI::Cookie->fetch($r);
-
-If the value passed to parse() is undefined, an empty array will returned in list
-context, and an empty hashref will be returned in scalar context.
-
-=head2 Manipulating Cookies
-
-Cookie objects have a series of accessor methods to get and set cookie
-attributes. Each accessor has a similar syntax. Called without
-arguments, the accessor returns the current value of the attribute.
-Called with an argument, the accessor changes the attribute and
-returns its new value.
-
-=over 4
-
-=item B<name()>
-
-Get or set the cookie's name. Example:
-
- $name = $c->name;
- $new_name = $c->name('fred');
-
-=item B<value()>
-
-Get or set the cookie's value. Example:
-
- $value = $c->value;
- @new_value = $c->value(['a','b','c','d']);
-
-B<value()> is context sensitive. In a list context it will return
-the current value of the cookie as an array. In a scalar context it
-will return the B<first> value of a multivalued cookie.
-
-=item B<domain()>
-
-Get or set the cookie's domain.
-
-=item B<path()>
-
-Get or set the cookie's path.
-
-=item B<expires()>
-
-Get or set the cookie's expiration time.
-
-=back
-
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1997-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org
-
-=head1 BUGS
-
-This section intentionally left blank.
-
-=head1 SEE ALSO
-
-L<CGI::Carp>, L<CGI>
-
-L<RFC 2109|http://www.ietf.org/rfc/rfc2109.txt>, L<RFC 2695|http://www.ietf.org/rfc/rfc2965.txt>
-
-=cut
+++ /dev/null
-package CGI::Fast;
-use strict;
-use if $] >= 5.019, 'deprecate';
-
-# A way to say "use warnings" that's compatible with even older perls.
-# making it local will not affect the code that loads this module
-# and since we're not in a BLOCK, warnings are enabled until the EOF
-local $^W = 1;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-$CGI::Fast::VERSION='1.10';
-
-use CGI;
-use FCGI;
-# use vars works like "our", but is compatible with older Perls.
-use vars qw(
- @ISA
- $ignore
-);
-@ISA = ('CGI');
-
-# workaround for known bug in libfcgi
-while (($ignore) = each %ENV) { }
-
-# override the initialization behavior so that
-# state is NOT maintained between invocations
-sub save_request {
- # no-op
-}
-
-# If ENV{FCGI_SOCKET_PATH} is specified, we maintain a FCGI Request handle
-# in this package variable.
-use vars qw($Ext_Request);
-BEGIN {
- # If ENV{FCGI_SOCKET_PATH} is given, explicitly open the socket.
- if ($ENV{FCGI_SOCKET_PATH}) {
- my $path = $ENV{FCGI_SOCKET_PATH};
- my $backlog = $ENV{FCGI_LISTEN_QUEUE} || 100;
- my $socket = FCGI::OpenSocket( $path, $backlog );
- $Ext_Request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR,
- \%ENV, $socket, 1 );
- }
- else {
- $Ext_Request = FCGI::Request();
- }
-}
-
-sub new {
- my ($self, $initializer, @param) = @_;
- unless (defined $initializer) {
- return undef unless $Ext_Request->Accept() >= 0;
- }
- CGI->_reset_globals;
- $self->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
- return $CGI::Q = $self->SUPER::new($initializer, @param);
-}
-
-1;
-
-=head1 NAME
-
-CGI::Fast - CGI Interface for Fast CGI
-
-=head1 SYNOPSIS
-
- use CGI::Fast qw(:standard);
- $COUNTER = 0;
- while (new CGI::Fast) {
- print header;
- print start_html("Fast CGI Rocks");
- print
- h1("Fast CGI Rocks"),
- "Invocation number ",b($COUNTER++),
- " PID ",b($$),".",
- hr;
- print end_html;
- }
-
-=head1 DESCRIPTION
-
-CGI::Fast is a subclass of the CGI object created by CGI.pm. It is
-specialized to work well FCGI module, which greatly speeds up CGI
-scripts by turning them into persistently running server processes.
-Scripts that perform time-consuming initialization processes, such as
-loading large modules or opening persistent database connections, will
-see large performance improvements.
-
-=head1 OTHER PIECES OF THE PUZZLE
-
-In order to use CGI::Fast you'll need the FCGI module. See
-http://www.cpan.org/ for details.
-
-=head1 WRITING FASTCGI PERL SCRIPTS
-
-FastCGI scripts are persistent: one or more copies of the script
-are started up when the server initializes, and stay around until
-the server exits or they die a natural death. After performing
-whatever one-time initialization it needs, the script enters a
-loop waiting for incoming connections, processing the request, and
-waiting some more.
-
-A typical FastCGI script will look like this:
-
- #!/usr/bin/perl
- use CGI::Fast;
- &do_some_initialization();
- while ($q = new CGI::Fast) {
- &process_request($q);
- }
-
-Each time there's a new request, CGI::Fast returns a
-CGI object to your loop. The rest of the time your script
-waits in the call to new(). When the server requests that
-your script be terminated, new() will return undef. You can
-of course exit earlier if you choose. A new version of the
-script will be respawned to take its place (this may be
-necessary in order to avoid Perl memory leaks in long-running
-scripts).
-
-CGI.pm's default CGI object mode also works. Just modify the loop
-this way:
-
- while (new CGI::Fast) {
- &process_request;
- }
-
-Calls to header(), start_form(), etc. will all operate on the
-current request.
-
-=head1 INSTALLING FASTCGI SCRIPTS
-
-See the FastCGI developer's kit documentation for full details. On
-the Apache server, the following line must be added to srm.conf:
-
- AddType application/x-httpd-fcgi .fcgi
-
-FastCGI scripts must end in the extension .fcgi. For each script you
-install, you must add something like the following to srm.conf:
-
- FastCgiServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
-
-This instructs Apache to launch two copies of file_upload.fcgi at
-startup time.
-
-=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS
-
-Any script that works correctly as a FastCGI script will also work
-correctly when installed as a vanilla CGI script. However it will
-not see any performance benefit.
-
-=head1 EXTERNAL FASTCGI SERVER INVOCATION
-
-FastCGI supports a TCP/IP transport mechanism which allows FastCGI scripts to run
-external to the webserver, perhaps on a remote machine. To configure the
-webserver to connect to an external FastCGI server, you would add the following
-to your srm.conf:
-
- FastCgiExternalServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -host sputnik:8888
-
-Two environment variables affect how the C<CGI::Fast> object is created,
-allowing C<CGI::Fast> to be used as an external FastCGI server. (See C<FCGI>
-documentation for C<FCGI::OpenSocket> for more information.)
-
-=over
-
-=item FCGI_SOCKET_PATH
-
-The address (TCP/IP) or path (UNIX Domain) of the socket the external FastCGI
-script to which bind an listen for incoming connections from the web server.
-
-=item FCGI_LISTEN_QUEUE
-
-Maximum length of the queue of pending connections.
-
-=back
-
-For example:
-
- #!/usr/local/bin/perl # must be a FastCGI version of perl!
- use CGI::Fast;
- &do_some_initialization();
- $ENV{FCGI_SOCKET_PATH} = "sputnik:8888";
- $ENV{FCGI_LISTEN_QUEUE} = 100;
- while ($q = new CGI::Fast) {
- &process_request($q);
- }
-
-=head1 CAVEATS
-
-I haven't tested this very much.
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1996-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org
-
-=head1 BUGS
-
-This section intentionally left blank.
-
-=head1 SEE ALSO
-
-L<CGI::Carp>, L<CGI>
-
-=cut
+++ /dev/null
-package CGI::Pretty;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-use strict;
-use if $] >= 5.019, 'deprecate';
-use CGI ();
-
-$CGI::Pretty::VERSION = '3.64';
-$CGI::DefaultClass = __PACKAGE__;
-$CGI::Pretty::AutoloadClass = 'CGI';
-@CGI::Pretty::ISA = qw( CGI );
-
-initialize_globals();
-
-sub _prettyPrint {
- my $input = shift;
- return if !$$input;
- return if !$CGI::Pretty::LINEBREAK || !$CGI::Pretty::INDENT;
-
-# print STDERR "'", $$input, "'\n";
-
- foreach my $i ( @CGI::Pretty::AS_IS ) {
- if ( $$input =~ m{</$i>}si ) {
- my ( $a, $b, $c ) = $$input =~ m{(.*)(<$i[\s/>].*?</$i>)(.*)}si;
- next if !$b;
- $a ||= "";
- $c ||= "";
-
- _prettyPrint( \$a ) if $a;
- _prettyPrint( \$c ) if $c;
-
- $b ||= "";
- $$input = "$a$b$c";
- return;
- }
- }
- $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g;
-}
-
-sub comment {
- my($self,@p) = CGI::self_or_CGI(@_);
-
- my $s = "@p";
- $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK;
-
- return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK;
-}
-
-sub _make_tag_func {
- my ($self,$tagname) = @_;
-
- # As Lincoln as noted, the last else clause is VERY hairy, and it
- # took me a while to figure out what I was trying to do.
- # What it does is look for tags that shouldn't be indented (e.g. PRE)
- # and makes sure that when we nest tags, those tags don't get
- # indented.
- # For an example, try print td( pre( "hello\nworld" ) );
- # If we didn't care about stuff like that, the code would be
- # MUCH simpler. BTW: I won't claim to be a regular expression
- # guru, so if anybody wants to contribute something that would
- # be quicker, easier to read, etc, I would be more than
- # willing to put it in - Brian
-
- my $func = qq"
- sub $tagname {";
-
- $func .= q'
- shift if $_[0] &&
- (ref($_[0]) &&
- (substr(ref($_[0]),0,3) eq "CGI" ||
- UNIVERSAL::isa($_[0],"CGI")));
- my($attr) = "";
- if (ref($_[0]) && ref($_[0]) eq "HASH") {
- my(@attr) = make_attributes(shift()||undef,1);
- $attr = " @attr" if @attr;
- }';
-
- if ($tagname=~/start_(\w+)/i) {
- $func .= qq!
- return "<\L$1\E\$attr>\$CGI::Pretty::LINEBREAK";} !;
- } elsif ($tagname=~/end_(\w+)/i) {
- $func .= qq!
- return "<\L/$1\E>\$CGI::Pretty::LINEBREAK"; } !;
- } else {
- $func .= qq#
- return ( \$CGI::XHTML ? "<\L$tagname\E\$attr />" : "<\L$tagname\E\$attr>" ) .
- \$CGI::Pretty::LINEBREAK unless \@_;
- my(\$tag,\$untag) = ("<\L$tagname\E\$attr>","</\L$tagname>\E");
-
- my \%ASIS = map { lc("\$_") => 1 } \@CGI::Pretty::AS_IS;
- my \@args;
- if ( \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT ) {
- if(ref(\$_[0]) eq 'ARRAY') {
- \@args = \@{\$_[0]}
- } else {
- foreach (\@_) {
- \$args[0] .= \$_;
- \$args[0] .= \$CGI::Pretty::LINEBREAK if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 0;
- chomp \$args[0] if exists \$ASIS{ "\L$tagname\E" };
-
- \$args[0] .= \$" if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 1;
- }
- chop \$args[0] unless \$" eq "";
- }
- }
- else {
- \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_";
- }
-
- my \@result;
- if ( exists \$ASIS{ "\L$tagname\E" } ) {
- \@result = map { "\$tag\$_\$untag" } \@args;
- }
- else {
- \@result = map {
- chomp;
- my \$tmp = \$_;
- CGI::Pretty::_prettyPrint( \\\$tmp );
- \$tag . \$CGI::Pretty::LINEBREAK .
- \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK .
- \$untag . \$CGI::Pretty::LINEBREAK
- } \@args;
- }
- if (\$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT) {
- return join ("", \@result);
- } else {
- return "\@result";
- }
- }#;
- }
-
- return $func;
-}
-
-sub start_html {
- return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK;
-}
-
-sub end_html {
- return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK;
-}
-
-sub new {
- my $class = shift;
- my $this = $class->SUPER::new( @_ );
-
- if ($CGI::MOD_PERL) {
- if ($CGI::MOD_PERL == 1) {
- my $r = Apache->request;
- $r->register_cleanup(\&CGI::Pretty::_reset_globals);
- }
- else {
- my $r = Apache2::RequestUtil->request;
- $r->pool->cleanup_register(\&CGI::Pretty::_reset_globals);
- }
- }
- $class->_reset_globals if $CGI::PERLEX;
-
- return bless $this, $class;
-}
-
-sub initialize_globals {
- # This is the string used for indentation of tags
- $CGI::Pretty::INDENT = "\t";
-
- # This is the string used for separation between tags
- $CGI::Pretty::LINEBREAK = $/;
-
- # These tags are not prettify'd.
- # When this list is updated, also update the docs.
- @CGI::Pretty::AS_IS = qw( a pre code script textarea td );
-
- 1;
-}
-sub _reset_globals { initialize_globals(); }
-
-# ugly, but quick fix
-sub import {
- my $self = shift;
- no strict 'refs';
- ${ "$self\::AutoloadClass" } = 'CGI';
-
- # This causes modules to clash.
- undef %CGI::EXPORT;
- undef %CGI::EXPORT;
-
- $self->_setup_symbols(@_);
- my ($callpack, $callfile, $callline) = caller;
-
- # To allow overriding, search through the packages
- # Till we find one in which the correct subroutine is defined.
- my @packages = ($self,@{"$self\:\:ISA"});
- foreach my $sym (keys %CGI::EXPORT) {
- my $pck;
- my $def = ${"$self\:\:AutoloadClass"} || $CGI::DefaultClass;
- foreach $pck (@packages) {
- if (defined(&{"$pck\:\:$sym"})) {
- $def = $pck;
- last;
- }
- }
- *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
- }
-}
-
-1;
-
-=head1 NAME
-
-CGI::Pretty - module to produce nicely formatted HTML code
-
-=head1 SYNOPSIS
-
- use CGI::Pretty qw( :html3 );
-
- # Print a table with a single data element
- print table( TR( td( "foo" ) ) );
-
-=head1 DESCRIPTION
-
-CGI::Pretty is a module that derives from CGI. It's sole function is to
-allow users of CGI to output nicely formatted HTML code.
-
-When using the CGI module, the following code:
- print table( TR( td( "foo" ) ) );
-
-produces the following output:
- <TABLE><TR><TD>foo</TD></TR></TABLE>
-
-If a user were to create a table consisting of many rows and many columns,
-the resultant HTML code would be quite difficult to read since it has no
-carriage returns or indentation.
-
-CGI::Pretty fixes this problem. What it does is add a carriage
-return and indentation to the HTML code so that one can easily read
-it.
-
- print table( TR( td( "foo" ) ) );
-
-now produces the following output:
- <TABLE>
- <TR>
- <TD>foo</TD>
- </TR>
- </TABLE>
-
-=head2 Recommendation for when to use CGI::Pretty
-
-CGI::Pretty is far slower than using CGI.pm directly. A benchmark showed that
-it could be about 10 times slower. Adding newlines and spaces may alter the
-rendered appearance of HTML. Also, the extra newlines and spaces also make the
-file size larger, making the files take longer to download.
-
-With all those considerations, it is recommended that CGI::Pretty be used
-primarily for debugging.
-
-=head2 Tags that won't be formatted
-
-The following tags are not formatted: <a>, <pre>, <code>, <script>, <textarea>, and <td>.
-If these tags were formatted, the
-user would see the extra indentation on the web browser causing the page to
-look different than what would be expected. If you wish to add more tags to
-the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
-
- push @CGI::Pretty::AS_IS,qw(XMP);
-
-=head2 Customizing the Indenting
-
-If you wish to have your own personal style of indenting, you can change the
-C<$INDENT> variable:
-
- $CGI::Pretty::INDENT = "\t\t";
-
-would cause the indents to be two tabs.
-
-Similarly, if you wish to have more space between lines, you may change the
-C<$LINEBREAK> variable:
-
- $CGI::Pretty::LINEBREAK = "\n\n";
-
-would create two carriage returns between lines.
-
-If you decide you want to use the regular CGI indenting, you can easily do
-the following:
-
- $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
-
-=head1 AUTHOR
-
-Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
-Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
-distribution.
-
-Copyright 1999, Brian Paulsen. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Bug reports and comments to Brian@ThePaulsens.com. You can also write
-to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
-sure I understand it!
-
-=head1 SEE ALSO
-
-L<CGI>
-
-=cut
+++ /dev/null
-package CGI::Push;
-use if $] >= 5.019, 'deprecate';
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995-2000, Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-# The most recent version and complete docs are available at:
-# http://stein.cshl.org/WWW/software/CGI/
-
-$CGI::Push::VERSION='1.06';
-use CGI;
-use CGI::Util 'rearrange';
-@ISA = ('CGI');
-
-$CGI::DefaultClass = 'CGI::Push';
-$CGI::Push::AutoloadClass = 'CGI';
-
-# add do_push() and push_delay() to exported tags
-push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay');
-
-sub do_push {
- my ($self,@p) = CGI::self_or_default(@_);
-
- # unbuffer output
- $| = 1;
- srand;
- my ($random) = sprintf("%08.0f",rand()*1E8);
- my ($boundary) = "----=_NeXtPaRt$random";
-
- my (@header);
- my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
- $type = 'text/html' unless $type;
- $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
- $delay = 1 unless defined($delay);
- $self->push_delay($delay);
- $nph = 1 unless defined($nph);
-
- my(@o);
- foreach (@other) { push(@o,split("=")); }
- push(@o,'-Target'=>$target) if defined($target);
- push(@o,'-Cookie'=>$cookie) if defined($cookie);
- push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\"");
- push(@o,'-Server'=>"CGI.pm Push Module") if $nph;
- push(@o,'-Status'=>'200 OK');
- push(@o,'-nph'=>1) if $nph;
- print $self->header(@o);
-
- $boundary = "$CGI::CRLF--$boundary";
-
- print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF";
-
- my (@contents) = &$callback($self,++$COUNTER);
-
- # now we enter a little loop
- while (1) {
- print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
- print @contents;
- @contents = &$callback($self,++$COUNTER);
- if ((@contents) && defined($contents[0])) {
- print "${boundary}$CGI::CRLF";
- do_sleep($self->push_delay()) if $self->push_delay();
- } else {
- if ($last_page && ref($last_page) eq 'CODE') {
- print "${boundary}$CGI::CRLF";
- do_sleep($self->push_delay()) if $self->push_delay();
- print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
- print &$last_page($self,$COUNTER);
- }
- print "${boundary}--$CGI::CRLF";
- last;
- }
- }
- print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$CGI::CRLF";
-}
-
-sub simple_counter {
- my ($self,$count) = @_;
- return $self->start_html("CGI::Push Default Counter"),
- $self->h1("CGI::Push Default Counter"),
- "This page has been updated ",$self->strong($count)," times.",
- $self->hr(),
- $self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'),
- $self->end_html;
-}
-
-sub do_sleep {
- my $delay = shift;
- if ( ($delay >= 1) && ($delay!~/\./) ){
- sleep($delay);
- } else {
- select(undef,undef,undef,$delay);
- }
-}
-
-sub push_delay {
- my ($self,$delay) = CGI::self_or_default(@_);
- return defined($delay) ? $self->{'.delay'} =
- $delay : $self->{'.delay'};
-}
-
-1;
-
-=head1 NAME
-
-CGI::Push - Simple Interface to Server Push
-
-=head1 SYNOPSIS
-
- use CGI::Push qw(:standard);
-
- do_push(-next_page=>\&next_page,
- -last_page=>\&last_page,
- -delay=>0.5);
-
- sub next_page {
- my($q,$counter) = @_;
- return undef if $counter >= 10;
- return start_html('Test'),
- h1('Visible'),"\n",
- "This page has been called ", strong($counter)," times",
- end_html();
- }
-
- sub last_page {
- my($q,$counter) = @_;
- return start_html('Done'),
- h1('Finished'),
- strong($counter - 1),' iterations.',
- end_html;
- }
-
-=head1 DESCRIPTION
-
-CGI::Push is a subclass of the CGI object created by CGI.pm. It is
-specialized for server push operations, which allow you to create
-animated pages whose content changes at regular intervals.
-
-You provide CGI::Push with a pointer to a subroutine that will draw
-one page. Every time your subroutine is called, it generates a new
-page. The contents of the page will be transmitted to the browser
-in such a way that it will replace what was there beforehand. The
-technique will work with HTML pages as well as with graphics files,
-allowing you to create animated GIFs.
-
-Only Netscape Navigator supports server push. Internet Explorer
-browsers do not.
-
-=head1 USING CGI::Push
-
-CGI::Push adds one new method to the standard CGI suite, do_push().
-When you call this method, you pass it a reference to a subroutine
-that is responsible for drawing each new page, an interval delay, and
-an optional subroutine for drawing the last page. Other optional
-parameters include most of those recognized by the CGI header()
-method.
-
-You may call do_push() in the object oriented manner or not, as you
-prefer:
-
- use CGI::Push;
- $q = new CGI::Push;
- $q->do_push(-next_page=>\&draw_a_page);
-
- -or-
-
- use CGI::Push qw(:standard);
- do_push(-next_page=>\&draw_a_page);
-
-Parameters are as follows:
-
-=over 4
-
-=item -next_page
-
- do_push(-next_page=>\&my_draw_routine);
-
-This required parameter points to a reference to a subroutine responsible for
-drawing each new page. The subroutine should expect two parameters
-consisting of the CGI object and a counter indicating the number
-of times the subroutine has been called. It should return the
-contents of the page as an B<array> of one or more items to print.
-It can return a false value (or an empty array) in order to abort the
-redrawing loop and print out the final page (if any)
-
- sub my_draw_routine {
- my($q,$counter) = @_;
- return undef if $counter > 100;
- return start_html('testing'),
- h1('testing'),
- "This page called $counter times";
- }
-
-You are of course free to refer to create and use global variables
-within your draw routine in order to achieve special effects.
-
-=item -last_page
-
-This optional parameter points to a reference to the subroutine
-responsible for drawing the last page of the series. It is called
-after the -next_page routine returns a false value. The subroutine
-itself should have exactly the same calling conventions as the
--next_page routine.
-
-=item -type
-
-This optional parameter indicates the content type of each page. It
-defaults to "text/html". Normally the module assumes that each page
-is of a homogeneous MIME type. However if you provide either of the
-magic values "heterogeneous" or "dynamic" (the latter provided for the
-convenience of those who hate long parameter names), you can specify
-the MIME type -- and other header fields -- on a per-page basis. See
-"heterogeneous pages" for more details.
-
-=item -delay
-
-This indicates the delay, in seconds, between frames. Smaller delays
-refresh the page faster. Fractional values are allowed.
-
-B<If not specified, -delay will default to 1 second>
-
-=item -cookie, -target, -expires, -nph
-
-These have the same meaning as the like-named parameters in
-CGI::header().
-
-If not specified, -nph will default to 1 (as needed for many servers, see below).
-
-=back
-
-=head2 Heterogeneous Pages
-
-Ordinarily all pages displayed by CGI::Push share a common MIME type.
-However by providing a value of "heterogeneous" or "dynamic" in the
-do_push() -type parameter, you can specify the MIME type of each page
-on a case-by-case basis.
-
-If you use this option, you will be responsible for producing the
-HTTP header for each page. Simply modify your draw routine to
-look like this:
-
- sub my_draw_routine {
- my($q,$counter) = @_;
- return header('text/html'), # note we're producing the header here
- start_html('testing'),
- h1('testing'),
- "This page called $counter times";
- }
-
-You can add any header fields that you like, but some (cookies and
-status fields included) may not be interpreted by the browser. One
-interesting effect is to display a series of pages, then, after the
-last page, to redirect the browser to a new URL. Because redirect()
-does b<not> work, the easiest way is with a -refresh header field,
-as shown below:
-
- sub my_draw_routine {
- my($q,$counter) = @_;
- return undef if $counter > 10;
- return header('text/html'), # note we're producing the header here
- start_html('testing'),
- h1('testing'),
- "This page called $counter times";
- }
-
- sub my_last_page {
- return header(-refresh=>'5; URL=http://somewhere.else/finished.html',
- -type=>'text/html'),
- start_html('Moved'),
- h1('This is the last page'),
- 'Goodbye!'
- hr,
- end_html;
- }
-
-=head2 Changing the Page Delay on the Fly
-
-If you would like to control the delay between pages on a page-by-page
-basis, call push_delay() from within your draw routine. push_delay()
-takes a single numeric argument representing the number of seconds you
-wish to delay after the current page is displayed and before
-displaying the next one. The delay may be fractional. Without
-parameters, push_delay() just returns the current delay.
-
-=head1 INSTALLING CGI::Push SCRIPTS
-
-Server push scripts must be installed as no-parsed-header (NPH)
-scripts in order to work correctly on many servers. On Unix systems,
-this is most often accomplished by prefixing the script's name with "nph-".
-Recognition of NPH scripts happens automatically with WebSTAR and
-Microsoft IIS. Users of other servers should see their documentation
-for help.
-
-Apache web server from version 1.3b2 on does not need server
-push scripts installed as NPH scripts: the -nph parameter to do_push()
-may be set to a false value to disable the extra headers needed by an
-NPH script.
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org
-
-=head1 BUGS
-
-This section intentionally left blank.
-
-=head1 SEE ALSO
-
-L<CGI::Carp>, L<CGI>
-
-=cut
-
+++ /dev/null
-package CGI::Switch;
-use if $] >= 5.019, 'deprecate';
-use CGI;
-
-$VERSION = '1.02';
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI::Switch - Backward compatibility module for defunct CGI::Switch
-
-=head1 SYNOPSIS
-
-Do not use this module. It is deprecated.
-
-=head1 ABSTRACT
-
-=head1 DESCRIPTION
-
-=head1 AUTHOR INFORMATION
-
-=head1 BUGS
-
-=head1 SEE ALSO
-
-=cut
+++ /dev/null
-package CGI::Util;
-use base 'Exporter';
-require 5.008001;
-use strict;
-use if $] >= 5.019, 'deprecate';
-our @EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
- expires ebcdic2ascii ascii2ebcdic);
-
-our $VERSION = '3.64';
-
-use constant EBCDIC => "\t" ne "\011";
-
-# This option is not documented and may change or go away.
-# The HTML spec does not require attributes to be sorted,
-# but it's useful for testing to get a predictable order back.
-our $SORT_ATTRIBUTES;
-
-# (ord('^') == 95) for codepage 1047 as on os390, vmesa
-our @A2E = (
- 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
- 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
- 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
- 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
- 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
- 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
- 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
- 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
- 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
- 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
- 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
- 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
- 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
- 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
- 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
- );
-our @E2A = (
- 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
- 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
- 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
- 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
- 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
- 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
- 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
- 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
- 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
- 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
- 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
- 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
- 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
- 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
- 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
- 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
- );
-
-if (EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
- $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
- $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
- $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
- $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
- $A2E[249] = 192;
-
- $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
- $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
- $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
- $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
- $E2A[255] = 126;
- }
-elsif (EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
- $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
- $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
-
- $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
- $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
-}
-
-# Smart rearrangement of parameters to allow named parameter
-# calling. We do the rearrangement if:
-# the first parameter begins with a -
-
-sub rearrange {
- my ($order,@param) = @_;
- my ($result, $leftover) = _rearrange_params( $order, @param );
- push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
- if keys %$leftover;
- @$result;
-}
-
-sub rearrange_header {
- my ($order,@param) = @_;
-
- my ($result,$leftover) = _rearrange_params( $order, @param );
- push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
-
- @$result;
-}
-
-sub _rearrange_params {
- my($order,@param) = @_;
- return [] unless @param;
-
- if (ref($param[0]) eq 'HASH') {
- @param = %{$param[0]};
- } else {
- return \@param
- unless (defined($param[0]) && substr($param[0],0,1) eq '-');
- }
-
- # map parameters into positional indices
- my ($i,%pos);
- $i = 0;
- foreach (@$order) {
- foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
- $i++;
- }
-
- my (@result,%leftover);
- $#result = $#$order; # preextend
- while (@param) {
- my $key = lc(shift(@param));
- $key =~ s/^\-//;
- if (exists $pos{$key}) {
- $result[$pos{$key}] = shift(@param);
- } else {
- $leftover{$key} = shift(@param);
- }
- }
-
- return \@result, \%leftover;
-}
-
-sub make_attributes {
- my $attr = shift;
- return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
- my $escape = shift || 0;
- my $do_not_quote = shift;
-
- my $quote = $do_not_quote ? '' : '"';
-
- my @attr_keys= keys %$attr;
- if ($SORT_ATTRIBUTES) {
- @attr_keys= sort @attr_keys;
- }
- my(@att);
- foreach (@attr_keys) {
- my($key) = $_;
- $key=~s/^\-//; # get rid of initial - if present
-
- # old way: breaks EBCDIC!
- # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
-
- ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
-
- my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
- push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
- }
- return @att;
-}
-
-sub simple_escape {
- return unless defined(my $toencode = shift);
- $toencode =~ s{&}{&}gso;
- $toencode =~ s{<}{<}gso;
- $toencode =~ s{>}{>}gso;
- $toencode =~ s{\"}{"}gso;
-# Doesn't work. Can't work. forget it.
-# $toencode =~ s{\x8b}{‹}gso;
-# $toencode =~ s{\x9b}{›}gso;
- $toencode;
-}
-
-sub utf8_chr {
- my $c = shift(@_);
- my $u = chr($c);
- utf8::encode($u); # drop utf8 flag
- return $u;
-}
-
-# unescape URL-encoded data
-sub unescape {
- shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
- my $todecode = shift;
- return undef unless defined($todecode);
- $todecode =~ tr/+/ /; # pluses become spaces
- if (EBCDIC) {
- $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
- } else {
- # handle surrogate pairs first -- dankogai. Ref: http://unicode.org/faq/utf_bom.html#utf16-2
- $todecode =~ s{
- %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
- %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
- }{
- utf8_chr(
- 0x10000
- + (hex($1) - 0xD800) * 0x400
- + (hex($2) - 0xDC00)
- )
- }gex;
- $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
- defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
- }
- return $todecode;
-}
-
-# URL-encode data
-#
-# We cannot use the %u escapes, they were rejected by W3C, so the official
-# way is %XX-escaped utf-8 encoding.
-# Naturally, Unicode strings have to be converted to their utf-8 byte
-# representation.
-# Byte strings were traditionally used directly as a sequence of octets.
-# This worked if they actually represented binary data (i.e. in CGI::Compress).
-# This also worked if these byte strings were actually utf-8 encoded; e.g.,
-# when the source file used utf-8 without the appropriate "use utf8;".
-# This fails if the byte string is actually a Latin 1 encoded string, but it
-# was always so and cannot be fixed without breaking the binary data case.
-# -- Stepan Kasal <skasal@redhat.com>
-#
-
-sub escape {
- # If we being called in an OO-context, discard the first argument.
- shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
- my $toencode = shift;
- return undef unless defined($toencode);
- utf8::encode($toencode) if utf8::is_utf8($toencode);
- if (EBCDIC) {
- $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
- } else {
- $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
- }
- return $toencode;
-}
-
-# This internal routine creates date strings suitable for use in
-# cookies and HTTP headers. (They differ, unfortunately.)
-# Thanks to Mark Fisher for this.
-sub expires {
- my($time,$format) = @_;
- $format ||= 'http';
-
- my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
- my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
-
- # pass through preformatted dates for the sake of expire_calc()
- $time = expire_calc($time);
- return $time unless $time =~ /^\d+$/;
-
- # make HTTP/cookie date string from GMT'ed time
- # (cookies use '-' as date separator, HTTP uses ' ')
- my($sc) = ' ';
- $sc = '-' if $format eq "cookie";
- my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
- $year += 1900;
- return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
- $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
-}
-
-# This internal routine creates an expires time exactly some number of
-# hours from the current time. It incorporates modifications from
-# Mark Fisher.
-sub expire_calc {
- my($time) = @_;
- my(%mult) = ('s'=>1,
- 'm'=>60,
- 'h'=>60*60,
- 'd'=>60*60*24,
- 'M'=>60*60*24*30,
- 'y'=>60*60*24*365);
- # format for time can be in any of the forms...
- # "now" -- expire immediately
- # "+180s" -- in 180 seconds
- # "+2m" -- in 2 minutes
- # "+12h" -- in 12 hours
- # "+1d" -- in 1 day
- # "+3M" -- in 3 months
- # "+2y" -- in 2 years
- # "-3m" -- 3 minutes ago(!)
- # If you don't supply one of these forms, we assume you are
- # specifying the date yourself
- my($offset);
- if (!$time || (lc($time) eq 'now')) {
- $offset = 0;
- } elsif ($time=~/^\d+/) {
- return $time;
- } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
- $offset = ($mult{$2} || 1)*$1;
- } else {
- return $time;
- }
- my $cur_time = time;
- return ($cur_time+$offset);
-}
-
-sub ebcdic2ascii {
- my $data = shift;
- $data =~ s/(.)/chr $E2A[ord($1)]/ge;
- $data;
-}
-
-sub ascii2ebcdic {
- my $data = shift;
- $data =~ s/(.)/chr $A2E[ord($1)]/ge;
- $data;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI::Util - Internal utilities used by CGI module
-
-=head1 SYNOPSIS
-
-none
-
-=head1 DESCRIPTION
-
-no public subroutines
-
-=head1 AUTHOR INFORMATION
-
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Address bug reports and comments to: lstein@cshl.org. When sending
-bug reports, please provide the version of CGI.pm, the version of
-Perl, the name and version of your Web server, and the name and
-version of the operating system you are using. If the problem is even
-remotely browser dependent, please provide information about the
-affected browsers as well.
-
-=head1 SEE ALSO
-
-L<CGI>
-
-=cut
+++ /dev/null
-use Test::More 'no_plan';
-use CGI;
-my $cgi = CGI->new('<a>=<b>');
-like($cgi->Dump, qr/\Q<a>/, 'param names are HTML escaped by Dump()');
-like($cgi->Dump, qr/\Q<b>/, 'param values are HTML escaped by Dump()');
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use strict;
-use Test::More tests => 1;
-
-# Can't do much with this other than make sure it loads properly
-BEGIN { use_ok('CGI::Apache') };
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 18;
-
-use CGI qw/ autoEscape escapeHTML button textfield password_field textarea popup_menu scrolling_list checkbox_group optgroup checkbox radio_group submit image_button button /;
-$CGI::Util::SORT_ATTRIBUTES = 1;
-
-is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "autoEscape defaults to On");
-
-my $before = escapeHTML("test<");
-autoEscape(undef);
-my $after = escapeHTML("test<");
-
-
-is($before, "test<", "reality check escapeHTML");
-
-is ($before, $after, "passing undef to autoEscape doesn't break escapeHTML");
-is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "turning off autoescape actually works");
-autoEscape(1);
-is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "autoescape turns back on");
-$before = escapeHTML("test<");
-autoEscape(0);
-$after = escapeHTML("test<");
-
-is ($before, $after, "passing 0 to autoEscape doesn't break escapeHTML");
-
-# RT #25485: Needs Tests: autoEscape() bypassed for Javascript handlers, except in button()
-autoEscape(undef);
-
-is(textfield(
-{
-default => 'text field',
-onclick => 'alert("===> text field")',
-},
-),
-qq{<input type="text" name="" value="text field" onclick="alert("===> text field")" />},
-'autoescape javascript turns off for textfield'
-);
-
-is(password_field(
-{
-default => 'password field',
-onclick => 'alert("===> password
-field")',
-},
-),
-qq{<input type="password" name="" value="password field" onclick="alert("===> password
-field")" />},
-'autoescape javascript turns off for password field'
-);
-
-is(textarea(
-{
-name => 'foo',
-default => 'text area',
-rows => 10,
-columns => 50,
-onclick => 'alert("===> text area")',
-},
-),
-qq{<textarea name="foo" rows="10" cols="50" onclick="alert("===> text area")">text area</textarea>},
-'autoescape javascript turns off for textarea'
-);
-
-is(popup_menu(
-{
-name => 'menu_name',
-values => ['eenie','meenie','minie'],
-default => 'meenie',
-onclick => 'alert("===> popup menu")',
-}
-),
-qq{<select name="menu_name" onclick="alert("===> popup menu")">
-<option value="eenie">eenie</option>
-<option selected="selected" value="meenie">meenie</option>
-<option value="minie">minie</option>
-</select>},
-'autoescape javascript turns off for popup_menu'
-);
-
-is(popup_menu(
--name=>'menu_name',
-onclick => 'alert("===> menu group")',
--values=>[
-qw/eenie meenie minie/,
-optgroup(
--name=>'optgroup_name',
-onclick =>
-'alert("===> menu group option")',
--values => ['moe','catch'],
--attributes=>{'catch'=>{'class'=>'red'}}
-)
-],
--labels=>{
-'eenie'=>'one',
-'meenie'=>'two',
-'minie'=>'three'
-},
--default=>'meenie'
-),
-qq{<select name="menu_name" onclick="alert("===> menu group")">
-<option value="eenie">one</option>
-<option selected="selected" value="meenie">two</option>
-<option value="minie">three</option>
-<optgroup label="optgroup_name" onclick="alert("===> menu group option")">
-<option value="moe">moe</option>
-<option class="red" value="catch">catch</option>
-</optgroup>
-</select>},
-'autoescape javascript turns off for popup_menu #2'
-);
-
-is(scrolling_list(
--name=>'list_name',
-onclick => 'alert("===> scrolling
-list")',
--values=>['eenie','meenie','minie','moe'],
--default=>['eenie','moe'],
--size=>5,
--multiple=>'true',
-),
-qq{<select name="list_name" size="5" multiple="multiple" onclick="alert("===> scrolling
-list")">
-<option selected="selected" value="eenie">eenie</option>
-<option value="meenie">meenie</option>
-<option value="minie">minie</option>
-<option selected="selected" value="moe">moe</option>
-</select>},
-'autoescape javascript turns off for scrolling list'
-);
-
-is(checkbox_group(
--name=>'group_name',
-onclick => 'alert("===> checkbox group")',
--values=>['eenie','meenie','minie','moe'],
--default=>['eenie','moe'],
--linebreak=>'true',
-),
-qq{<label><input type="checkbox" name="group_name" value="eenie" checked="checked" onclick="alert("===> checkbox group")" />eenie</label><br /> <label><input type="checkbox" name="group_name" value="meenie" onclick="alert("===> checkbox group")" />meenie</label><br /> <label><input type="checkbox" name="group_name" value="minie" onclick="alert("===> checkbox group")" />minie</label><br /> <label><input type="checkbox" name="group_name" value="moe" checked="checked" onclick="alert("===> checkbox group")" />moe</label><br />},
-'autoescape javascript turns off for checkbox group'
-);
-
-is(checkbox(
--name=>'checkbox_name',
-onclick => 'alert("===> single checkbox")',
-onchange => 'alert("===> single checkbox
-changed")',
--checked=>1,
--value=>'ON',
--label=>'CLICK ME'
-),
-qq{<label><input type="checkbox" name="checkbox_name" value="ON" checked="checked" onchange="alert("===> single checkbox
-changed")" onclick="alert("===> single checkbox")" />CLICK ME</label>},
-'autoescape javascript turns off for checkbox'
-);
-
-is(radio_group(
-{
-name=>'group_name',
-onclick => 'alert("===> radio group")',
-values=>['eenie','meenie','minie','moe'],
-rows=>2,
-columns=>2,
-}
-),
-qq{<table><tr><td><label><input type="radio" name="group_name" value="eenie" checked="checked" onclick="alert("===> radio group")" />eenie</label></td><td><label><input type="radio" name="group_name" value="minie" onclick="alert("===> radio group")" />minie</label></td></tr><tr><td><label><input type="radio" name="group_name" value="meenie" onclick="alert("===> radio group")" />meenie</label></td><td><label><input type="radio" name="group_name" value="moe" onclick="alert("===> radio group")" />moe</label></td></tr></table>},
-'autoescape javascript turns off for radio group'
-);
-
-is(submit(
--name=>'button_name',
-onclick => 'alert("===> submit button")',
--value=>'value'
-),
-qq{<input type="submit" name="button_name" value="value" onclick="alert("===> submit button")" />},
-'autoescape javascript turns off for submit'
-);
-
-is(image_button(
--name=>'button_name',
-onclick => 'alert("===> image button")',
--src=>'/source/URL',
--align=>'MIDDLE'
-),
-qq{<input type="image" name="button_name" src="/source/URL" align="middle" onclick="alert("===> image button")" />},
-'autoescape javascript turns off for image_button'
-);
-
-is(button(
-{
-onclick => 'alert("===> Button")',
-title => 'Button',
-},
-),
-qq{<input type="button" onclick="alert("===> Button")" title="Button" />},
-'autoescape javascript turns off for button'
-);
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use Test::More tests => 2;
-
-BEGIN{ use_ok('CGI'); }
-
-can_ok('CGI', qw/cookie param/);
+++ /dev/null
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
-#!perl -w
-
-use strict;
-
-use Test::More tests => 61;
-use IO::Handle;
-
-use CGI::Carp;
-
-#-----------------------------------------------------------------------------
-# Test id
-#-----------------------------------------------------------------------------
-
-# directly invoked
-my $expect_f = __FILE__;
-my $expect_l = __LINE__ + 1;
-my ($file, $line, $id) = CGI::Carp::id(0);
-is($file, $expect_f, "file");
-is($line, $expect_l, "line");
-is($id, "carp.t", "id");
-
-# one level of indirection
-sub id1 { my $level = shift; return CGI::Carp::id($level); };
-
-$expect_l = __LINE__ + 1;
-($file, $line, $id) = id1(1);
-is($file, $expect_f, "file");
-is($line, $expect_l, "line");
-is($id, "carp.t", "id");
-
-# two levels of indirection
-sub id2 { my $level = shift; return id1($level); };
-
-$expect_l = __LINE__ + 1;
-($file, $line, $id) = id2(2);
-is($file, $expect_f, "file");
-is($line, $expect_l, "line");
-is($id, "carp.t", "id");
-
-#-----------------------------------------------------------------------------
-# Test stamp
-#-----------------------------------------------------------------------------
-
-my $stamp = "/^\\[
- ([a-z]{3}\\s){2}\\s?
- [\\s\\d:]+
- \\]\\s$id:/ix";
-
-like(CGI::Carp::stamp(),
- $stamp,
- "Time in correct format");
-
-sub stamp1 {return CGI::Carp::stamp()};
-sub stamp2 {return stamp1()};
-
-like(stamp2(), $stamp, "Time in correct format");
-
-#-----------------------------------------------------------------------------
-# Test warn and _warn
-#-----------------------------------------------------------------------------
-
-# set some variables to control what's going on.
-$CGI::Carp::WARN = 0;
-$CGI::Carp::EMIT_WARNINGS = 0;
-my $q_file = quotemeta($file);
-
-
-# Test that realwarn is called
-{
- local $^W = 0;
- eval "sub CGI::Carp::realwarn {return 'Called realwarn'};";
-}
-
-$expect_l = __LINE__ + 1;
-is(CGI::Carp::warn("There is a problem"),
- "Called realwarn",
- "CGI::Carp::warn calls CORE::warn");
-
-# Test that message is constructed correctly
-eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};';
-
-$expect_l = __LINE__ + 1;
-like(CGI::Carp::warn("There is a problem"),
- "/] $id: There is a problem at $q_file line $expect_l.".'$/',
- "CGI::Carp::warn builds correct message");
-
-# Test that _warn is called at the correct time
-$CGI::Carp::WARN = 1;
-
-my $warn_expect_l = $expect_l = __LINE__ + 1;
-like(CGI::Carp::warn("There is a problem"),
- "/] $id: There is a problem at $q_file line $expect_l.".'$/',
- "CGI::Carp::warn builds correct message");
-
-#-----------------------------------------------------------------------------
-# Test ineval
-#-----------------------------------------------------------------------------
-
-ok(!CGI::Carp::ineval, 'ineval returns false when not in eval');
-eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');};
-
-#-----------------------------------------------------------------------------
-# Test die
-#-----------------------------------------------------------------------------
-
-# set some variables to control what's going on.
-$CGI::Carp::WRAP = 0;
-
-$expect_l = __LINE__ + 1;
-eval { CGI::Carp::die('There is a problem'); };
-like($@,
- '/^There is a problem/',
- 'CGI::Carp::die calls CORE::die without altering argument in eval');
-
-# Test that realwarn is called
-{
- local $^W = 0;
- local *CGI::Carp::realdie = sub { my $mess = shift; return $mess };
-
- like(CGI::Carp::die('There is a problem'),
- $stamp,
- 'CGI::Carp::die calls CORE::die, but adds stamp');
-
-}
-
-#-----------------------------------------------------------------------------
-# Test set_message
-#-----------------------------------------------------------------------------
-
-is(CGI::Carp::set_message('My new Message'),
- 'My new Message',
- 'CGI::Carp::set_message returns new message');
-
-is($CGI::Carp::CUSTOM_MSG,
- 'My new Message',
- 'CGI::Carp::set_message message set correctly');
-
-# set the message back to the empty string so that the tests later
-# work properly.
-CGI::Carp::set_message(''),
-
-#-----------------------------------------------------------------------------
-# Test set_progname
-#-----------------------------------------------------------------------------
-
-import CGI::Carp qw(name=new_progname);
-is($CGI::Carp::PROGNAME,
- 'new_progname',
- 'CGI::Carp::import set program name correctly');
-
-is(CGI::Carp::set_progname('newer_progname'),
- 'newer_progname',
- 'CGI::Carp::set_progname returns new program name');
-
-is($CGI::Carp::PROGNAME,
- 'newer_progname',
- 'CGI::Carp::set_progname program name set correctly');
-
-# set the message back to the empty string so that the tests later
-# work properly.
-is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly");
-is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly");
-
-#-----------------------------------------------------------------------------
-# Test warnings_to_browser
-#-----------------------------------------------------------------------------
-
-CGI::Carp::warningsToBrowser(0);
-is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off");
-
-# turn off STDOUT (prevents spurious warnings to screen
-tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
-CGI::Carp::warningsToBrowser(1);
-my $fake_out = join '', <STDOUT>;
-untie *STDOUT;
-
-open(STDOUT, ">&REAL_STDOUT");
-my $fname = $0;
-$fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also
-is( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n",
- 'warningsToBrowser() on' );
-
-is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");
-
-#-----------------------------------------------------------------------------
-# Test fatals_to_browser
-#-----------------------------------------------------------------------------
-
-package StoreStuff;
-
-sub TIEHANDLE {
- my $class = shift;
- bless [], $class;
-}
-
-sub PRINT {
- my $self = shift;
- push @$self, @_;
-}
-
-sub READLINE {
- my $self = shift;
- shift @$self;
-}
-
-package main;
-
-tie *STDOUT, "StoreStuff";
-
-# do tests
-my @result;
-
-CGI::Carp::fatalsToBrowser();
-$result[0] .= $_ while (<STDOUT>);
-
-CGI::Carp::fatalsToBrowser('Message to the world');
-$result[1] .= $_ while (<STDOUT>);
-
-$ENV{SERVER_ADMIN} = 'foo@bar.com';
-CGI::Carp::fatalsToBrowser();
-$result[2] .= $_ while (<STDOUT>);
-
-CGI::Carp::set_message('Override the message passed in'),
-
-CGI::Carp::fatalsToBrowser('Message to the world');
-$result[3] .= $_ while (<STDOUT>);
-CGI::Carp::set_message(''),
-delete $ENV{SERVER_ADMIN};
-
-# now restore STDOUT
-untie *STDOUT;
-
-
-like($result[0],
- '/Content-type: text/html/',
- "Default string has header");
-
-ok($result[0] !~ /Message to the world/, "Custom message not in default string");
-
-like($result[1],
- '/Message to the world/',
- "Custom Message appears in output");
-
-ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");
-
-like($result[2],
- '/foo@bar.com/',
- "Server Admin appears in output");
-
-like($result[3],
- '/Message to the world/',
- "Custom message not in result");
-
-like($result[3],
- '/Override the message passed in/',
- "Correct message in string");
-
-#-----------------------------------------------------------------------------
-# Test to_filehandle
-#-----------------------------------------------------------------------------
-
-sub buffer {
- CGI::Carp::to_filehandle (@_);
-}
-
-tie *STORE, "StoreStuff";
-
-require FileHandle;
-my $fh = FileHandle->new;
-
-ok( defined buffer(\*STORE), '\*STORE returns proper filehandle');
-ok( defined buffer( $fh ), '$fh returns proper filehandle');
-ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle');
-ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
-ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle');
-
-# Calling die with code refs with no WRAP
-{
- local $CGI::Carp::WRAP = 0;
-
- eval { CGI::Carp::die( 'regular string' ) };
- like $@ => qr/regular string/, 'die with string';
-
- eval { CGI::Carp::die( [ 1..10 ] ) };
- like $@ => qr/ARRAY\(0x[\da-f]+\)/, 'die with array ref';
-
- eval { CGI::Carp::die( { a => 1 } ) };
- like $@ => qr/HASH\(0x[\da-f]+\)/, 'die with hash ref';
-
- eval { CGI::Carp::die( sub { 'Farewell' } ) };
- like $@ => qr/CODE\(0x[\da-f]+\)/, 'die with code ref';
-
- eval { CGI::Carp::die( My::Plain::Object->new ) };
- isa_ok $@, 'My::Plain::Object';
-
- eval { CGI::Carp::die( My::Plain::Object->new, ' and another argument' ) };
- like $@ => qr/My::Plain::Object/, 'object is stringified';
- like $@ => qr/and another argument/, 'second argument is present';
-
- eval { CGI::Carp::die( My::Stringified::Object->new ) };
- isa_ok $@, 'My::Stringified::Object';
-
- eval { CGI::Carp::die( My::Stringified::Object->new, ' and another argument' ) };
- like $@ => qr/stringified/, 'object is stringified';
- like $@ => qr/and another argument/, 'second argument is present';
-
- eval { CGI::Carp::die() };
- like $@ => qr/Died at/, 'die with no argument';
-}
-
-# Calling die with code refs when WRAPped
-{
- local $CGI::Carp::WRAP = 1;
- local *CGI::Carp::realdie = sub { return @_ };
- local *STDOUT;
-
- tie *STDOUT, 'StoreStuff';
-
- my %result; # store results because stdout is kidnapped
-
- CGI::Carp::die( 'regular string' );
- $result{string} .= $_ while <STDOUT>;
-
- CGI::Carp::die( [ 1..10 ] );
- $result{array_ref} .= $_ while <STDOUT>;
-
- CGI::Carp::die( { a => 1 } );
- $result{hash_ref} .= $_ while <STDOUT>;
-
- CGI::Carp::die( sub { 'Farewell' } );
- $result{code_ref} .= $_ while <STDOUT>;
-
- CGI::Carp::die( My::Plain::Object->new );
- $result{plain_object} .= $_ while <STDOUT>;
-
- CGI::Carp::die( My::Stringified::Object->new );
- $result{string_object} .= $_ while <STDOUT>;
-
- undef $@;
- CGI::Carp::die();
- $result{no_args} .= $_ while <STDOUT>;
-
- $@ = "I think I caught a virus";
- CGI::Carp::die();
- $result{propagated} .= $_ while <STDOUT>;
-
- untie *STDOUT;
-
- like $result{string} => qr/regular string/, 'regular string, wrapped';
- like $result{array_ref} => qr/ARRAY\(\w+?\)/, 'array ref, wrapped';
- like $result{hash_ref} => qr/HASH\(\w+?\)/, 'hash ref, wrapped';
- like $result{code_ref} => qr/CODE\(\w+?\)/, 'code ref, wrapped';
- like $result{plain_object} => qr/My::Plain::Object/,
- 'plain object, wrapped';
- like $result{string_object} => qr/stringified/,
- 'stringified object, wrapped';
- like $result{no_args} => qr/Died at/, 'no args, wrapped';
-
- like $result{propagated} => qr/I think I caught a virus\t\.{3}propagated/,
- 'propagating $@ if no argument';
-
-}
-
-{
- package My::Plain::Object;
-
- sub new {
- return bless {}, shift;
- }
-}
-
-{
- package My::Stringified::Object;
-
- use overload '""' => sub { 'stringified' };
-
- sub new {
- return bless {}, shift;
- }
-}
-
-
-@result = ();
-tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
- {
- eval {
- $CGI::Carp::TO_BROWSER = 0;
- die 'Message ToBrowser = 0';
- };
- $result[0] = $@;
- $result[1] .= $_ while (<STDOUT>);
- }
-untie *STDOUT;
-
- like $result[0] => qr/Message ToBrowser/, 'die message for ToBrowser = 0 is OK';
- ok !$result[1], 'No output for ToBrowser = 0';
-
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use Test::More 'no_plan';
-
-use CGI;
-
-my $q = CGI->new;
-
-like( $q->header
- , qr/charset=ISO-8859-1/, "charset ISO-8859-1 is set by default for default content-type");
-like( $q->header('application/json')
- , qr/charset=ISO-8859-1/, "charset ISO-8859-1 is set by default for application/json content-type");
-
-{
- $q->charset('UTF-8');
- my $out = $q->header('text/plain');
- like($out, qr{Content-Type: text/plain; charset=UTF-8}, "setting charset alters header of text/plain");
-}
-{
- $q->charset('UTF-8');
- my $out = $q->header('application/json');
- like($out, qr{Content-Type: application/json; charset=UTF-8}, "setting charset alters header of application/json");
-}
-
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use Test::More tests => 3;
-
-BEGIN { use_ok('CGI'); };
-use CGI (':standard','-no_debug','-no_xhtml');
-
-# no_xhtml test on checkbox_group()
-is(checkbox_group(-name => 'game',
- '-values' => [qw/checkers chess cribbage/],
- '-defaults' => ['cribbage']),
- qq(<input type="checkbox" name="game" value="checkers" >checkers <input type="checkbox" name="game" value="chess" >chess <input type="checkbox" name="game" value="cribbage" checked >cribbage),
- 'checkbox_group()');
-
-# xhtml test on checkbox_group()
-$CGI::XHTML = 1;
-is(checkbox_group(-name => 'game',
- '-values' => [qw/checkers chess cribbage/],
- '-defaults' => ['cribbage']),
- qq(<label><input type="checkbox" name="game" value="checkers" />checkers</label> <label><input type="checkbox" name="game" value="chess" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" />cribbage</label>),
- 'checkbox_group()');
+++ /dev/null
-#!perl -w
-
-use strict;
-
-# to have a consistent baseline, we nail the current time
-# to 100 seconds after the epoch
-BEGIN {
- *CORE::GLOBAL::time = sub { 100 };
-}
-
-use Test::More 'no_plan';
-use CGI::Util qw(escape unescape);
-use POSIX qw(strftime);
-use CGI::Cookie;
-
-#-----------------------------------------------------------------------------
-# make sure module loaded
-#-----------------------------------------------------------------------------
-
-my @test_cookie = (
- # including leading and trailing whitespace in first cookie
- ' foo=123 ; bar=qwerty; baz=wibble; qux=a1',
- 'foo=123; bar=qwerty; baz=wibble;',
- 'foo=vixen; bar=cow; baz=bitch; qux=politician',
- 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
- );
-
-#-----------------------------------------------------------------------------
-# Test parse
-#-----------------------------------------------------------------------------
-
-{
- my $result = CGI::Cookie->parse($test_cookie[0]);
- is(ref($result), 'HASH', "Hash ref returned in scalar context");
-
- my @result = CGI::Cookie->parse($test_cookie[0]);
- is(@result, 8, "returns correct number of fields");
-
- @result = CGI::Cookie->parse($test_cookie[1]);
- is(@result, 6, "returns correct number of fields");
-
- my %result = CGI::Cookie->parse($test_cookie[0]);
- is($result{foo}->value, '123', "cookie foo is correct");
- is($result{bar}->value, 'qwerty', "cookie bar is correct");
- is($result{baz}->value, 'wibble', "cookie baz is correct");
- is($result{qux}->value, 'a1', "cookie qux is correct");
-
- my @array = CGI::Cookie->parse('');
- my $scalar = CGI::Cookie->parse('');
- is_deeply(\@array, [], " parse('') returns an empty array in list context (undocumented)");
- is_deeply($scalar, {}, " parse('') returns an empty hashref in scalar context (undocumented)");
-
- @array = CGI::Cookie->parse(undef);
- $scalar = CGI::Cookie->parse(undef);
- is_deeply(\@array, [], " parse(undef) returns an empty array in list context (undocumented)");
- is_deeply($scalar, {}, " parse(undef) returns an empty hashref in scalar context (undocumented)");
-}
-
-#-----------------------------------------------------------------------------
-# Test fetch
-#-----------------------------------------------------------------------------
-
-{
- # make sure there are no cookies in the environment
- delete $ENV{HTTP_COOKIE};
- delete $ENV{COOKIE};
-
- my %result = CGI::Cookie->fetch();
- ok(keys %result == 0, "No cookies in environment, returns empty list");
-
- # now set a cookie in the environment and try again
- $ENV{HTTP_COOKIE} = $test_cookie[2];
- %result = CGI::Cookie->fetch();
- ok(eq_set([keys %result], [qw(foo bar baz qux)]),
- "expected cookies extracted");
-
- is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
- is($result{foo}->value, 'vixen', "cookie foo is correct");
- is($result{bar}->value, 'cow', "cookie bar is correct");
- is($result{baz}->value, 'bitch', "cookie baz is correct");
- is($result{qux}->value, 'politician', "cookie qux is correct");
-
- # Delete that and make sure it goes away
- delete $ENV{HTTP_COOKIE};
- %result = CGI::Cookie->fetch();
- ok(keys %result == 0, "No cookies in environment, returns empty list");
-
- # try another cookie in the other environment variable thats supposed to work
- $ENV{COOKIE} = $test_cookie[3];
- %result = CGI::Cookie->fetch();
- ok(eq_set([keys %result], [qw(foo bar baz qux)]),
- "expected cookies extracted");
-
- is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
- is($result{foo}->value, 'a phrase', "cookie foo is correct");
- is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
- is($result{baz}->value, '^wibble', "cookie baz is correct");
- is($result{qux}->value, "'", "cookie qux is correct");
-}
-
-#-----------------------------------------------------------------------------
-# Test raw_fetch
-#-----------------------------------------------------------------------------
-
-{
- # make sure there are no cookies in the environment
- delete $ENV{HTTP_COOKIE};
- delete $ENV{COOKIE};
-
- my %result = CGI::Cookie->raw_fetch();
- ok(keys %result == 0, "No cookies in environment, returns empty list");
-
- # now set a cookie in the environment and try again
- $ENV{HTTP_COOKIE} = $test_cookie[2];
- %result = CGI::Cookie->raw_fetch();
- ok(eq_set([keys %result], [qw(foo bar baz qux)]),
- "expected cookies extracted");
-
- is(ref($result{foo}), '', 'Plain scalar returned');
- is($result{foo}, 'vixen', "cookie foo is correct");
- is($result{bar}, 'cow', "cookie bar is correct");
- is($result{baz}, 'bitch', "cookie baz is correct");
- is($result{qux}, 'politician', "cookie qux is correct");
-
- # Delete that and make sure it goes away
- delete $ENV{HTTP_COOKIE};
- %result = CGI::Cookie->raw_fetch();
- ok(keys %result == 0, "No cookies in environment, returns empty list");
-
- # try another cookie in the other environment variable thats supposed to work
- $ENV{COOKIE} = $test_cookie[3];
- %result = CGI::Cookie->raw_fetch();
- ok(eq_set([keys %result], [qw(foo bar baz qux)]),
- "expected cookies extracted");
-
- is(ref($result{foo}), '', 'Plain scalar returned');
- is($result{foo}, 'a%20phrase', "cookie foo is correct");
- is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
- is($result{baz}, '%5Ewibble', "cookie baz is correct");
- is($result{qux}, '%27', "cookie qux is correct");
-
- $ENV{COOKIE} = '$Version=1; foo; $Path="/test"';
- %result = CGI::Cookie->raw_fetch();
- is($result{foo}, '', 'no value translates to empty string');
-}
-
-#-----------------------------------------------------------------------------
-# Test new
-#-----------------------------------------------------------------------------
-
-{
- # Try new with full information provided
- my $c = CGI::Cookie->new(-name => 'foo',
- -value => 'bar',
- -expires => '+3M',
- -domain => '.capricorn.com',
- -path => '/cgi-bin/database',
- -secure => 1,
- -httponly=> 1
- );
- is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
- is($c->name , 'foo', 'name is correct');
- is($c->value , 'bar', 'value is correct');
- like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
- is($c->domain , '.capricorn.com', 'domain is correct');
- is($c->path , '/cgi-bin/database', 'path is correct');
- ok($c->secure , 'secure attribute is set');
- ok( $c->httponly, 'httponly attribute is set' );
-
- # now try it with the only two manditory values (should also set the default path)
- $c = CGI::Cookie->new(-name => 'baz',
- -value => 'qux',
- );
- is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
- is($c->name , 'baz', 'name is correct');
- is($c->value , 'qux', 'value is correct');
- ok(!defined $c->expires, 'expires is not set');
- ok(!defined $c->domain , 'domain attributeis not set');
- is($c->path, '/', 'path atribute is set to default');
- ok(!defined $c->secure , 'secure attribute is set');
- ok( !defined $c->httponly, 'httponly attribute is not set' );
-
-# I'm really not happy about the restults of this section. You pass
-# the new method invalid arguments and it just merilly creates a
-# broken object :-)
-# I've commented them out because they currently pass but I don't
-# think they should. I think this is testing broken behaviour :-(
-
-# # This shouldn't work
-# $c = CGI::Cookie->new(-name => 'baz' );
-#
-# is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
-# is($c->name , 'baz', 'name is correct');
-# ok(!defined $c->value, "Value is undefined ");
-# ok(!defined $c->expires, 'expires is not set');
-# ok(!defined $c->domain , 'domain attributeis not set');
-# is($c->path , '/', 'path atribute is set to default');
-# ok(!defined $c->secure , 'secure attribute is set');
-
-}
-
-#-----------------------------------------------------------------------------
-# Test as_string
-#-----------------------------------------------------------------------------
-
-{
- my $c = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -expires => '+3M',
- -domain => '.pie-shop.com',
- -path => '/',
- -secure => 1,
- -httponly=> 1
- );
-
- my $name = $c->name;
- like($c->as_string, "/$name/", "Stringified cookie contains name");
-
- my $value = $c->value;
- like($c->as_string, "/$value/", "Stringified cookie contains value");
-
- my $expires = $c->expires;
- like($c->as_string, "/$expires/", "Stringified cookie contains expires");
-
- my $domain = $c->domain;
- like($c->as_string, "/$domain/", "Stringified cookie contains domain");
-
- my $path = $c->path;
- like($c->as_string, "/$path/", "Stringified cookie contains path");
-
- like($c->as_string, '/secure/', "Stringified cookie contains secure");
-
- like( $c->as_string, '/HttpOnly/',
- "Stringified cookie contains HttpOnly" );
-
- $c = CGI::Cookie->new(-name => 'Hamster-Jam',
- -value => 'Tulip',
- );
-
- $name = $c->name;
- like($c->as_string, "/$name/", "Stringified cookie contains name");
-
- $value = $c->value;
- like($c->as_string, "/$value/", "Stringified cookie contains value");
-
- ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
-
- ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
-
- $path = $c->path;
- like($c->as_string, "/$path/", "Stringified cookie contains path");
-
- ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
-
- ok( $c->as_string !~ /HttpOnly/,
- "Stringified cookie does not contain HttpOnly" );
-}
-
-#-----------------------------------------------------------------------------
-# Test compare
-#-----------------------------------------------------------------------------
-
-{
- my $c1 = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -expires => '+3M',
- -domain => '.pie-shop.com',
- -path => '/',
- -secure => 1
- );
-
- # have to use $c1->expires because the time will occasionally be
- # different between the two creates causing spurious failures.
- my $c2 = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -expires => $c1->expires,
- -domain => '.pie-shop.com',
- -path => '/',
- -secure => 1
- );
-
- # This looks titally whacked, but it does the -1, 0, 1 comparison
- # thing so 0 means they match
- is($c1->compare("$c1"), 0, "Cookies are identical");
- is( "$c1", "$c2", "Cookies are identical");
-
- $c1 = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -domain => '.foo.bar.com'
- );
-
- # have to use $c1->expires because the time will occasionally be
- # different between the two creates causing spurious failures.
- $c2 = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- );
-
- # This looks titally whacked, but it does the -1, 0, 1 comparison
- # thing so 0 (i.e. false) means they match
- is($c1->compare("$c1"), 0, "Cookies are identical");
- ok($c1->compare("$c2"), "Cookies are not identical");
-
- $c2->domain('.foo.bar.com');
- is($c1->compare("$c2"), 0, "Cookies are identical");
-}
-
-#-----------------------------------------------------------------------------
-# Test name, value, domain, secure, expires and path
-#-----------------------------------------------------------------------------
-
-{
- my $c = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -expires => '+3M',
- -domain => '.pie-shop.com',
- -path => '/',
- -secure => 1
- );
-
- is($c->name, 'Jam', 'name is correct');
- is($c->name('Clash'), 'Clash', 'name is set correctly');
- is($c->name, 'Clash', 'name now returns updated value');
-
- # this is insane! it returns a simple scalar but can't accept one as
- # an argument, you have to give it an arrary ref. It's totally
- # inconsitent with these other methods :-(
- is($c->value, 'Hamster', 'value is correct');
- is($c->value(['Gerbil']), 'Gerbil', 'value is set correctly');
- is($c->value, 'Gerbil', 'value now returns updated value');
-
- my $exp = $c->expires;
- like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
- like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
- like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
- isnt($c->expires, $exp, "Expiry time has changed");
-
- is($c->domain, '.pie-shop.com', 'domain is correct');
- is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
- is($c->domain, '.wibble.co.uk', 'domain now returns updated value');
-
- is($c->path, '/', 'path is correct');
- is($c->path('/basket/'), '/basket/', 'path is set correctly');
- is($c->path, '/basket/', 'path now returns updated value');
-
- ok($c->secure, 'secure attribute is set');
- ok(!$c->secure(0), 'secure attribute is cleared');
- ok(!$c->secure, 'secure attribute is cleared');
-}
-
-#----------------------------------------------------------------------------
-# Max-age
-#----------------------------------------------------------------------------
-
-MAX_AGE: {
- my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
- is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT';
- is $cookie->max_age => undef, 'max-age is undefined when setting expires';
-
- $cookie = CGI::Cookie->new( -name=>'a', 'value'=>'b' );
- $cookie->max_age( '+4d' );
-
- is $cookie->expires, undef, 'expires is undef when setting max_age';
- is $cookie->max_age => 4*24*60*60, 'setting via max-age';
-
- $cookie->max_age( '113' );
- is $cookie->max_age => 13, 'max_age(num) as delta';
-}
-
-
-#----------------------------------------------------------------------------
-# bake
-#----------------------------------------------------------------------------
-
-BAKE: {
- my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
- eval { $cookie->bake };
- is($@,'', "calling bake() without mod_perl should survive");
-}
-
-#-----------------------------------------------------------------------------
-# Apache2?::Cookie compatibility.
-#-----------------------------------------------------------------------------
-APACHEREQ: {
- my $r = Apache::Faker->new;
- isa_ok $r, 'Apache';
- ok my $c = CGI::Cookie->new(
- $r,
- -name => 'Foo',
- -value => 'Bar',
- ), 'Pass an Apache object to the CGI::Cookie constructor';
- isa_ok $c, 'CGI::Cookie';
- ok $c->bake($r), 'Bake the cookie';
- ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
- 'bake() should call headers_out->set()';
-
- $r = Apache2::Faker->new;
- isa_ok $r, 'Apache2::RequestReq';
- ok $c = CGI::Cookie->new(
- $r,
- -name => 'Foo',
- -value => 'Bar',
- ), 'Pass an Apache::RequestReq object to the CGI::Cookie constructor';
- isa_ok $c, 'CGI::Cookie';
- ok $c->bake($r), 'Bake the cookie';
- ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
- 'bake() should call headers_out->set()';
-}
-
-
-package Apache::Faker;
-sub new { bless {}, shift }
-sub isa {
- my ($self, $pkg) = @_;
- return $pkg eq 'Apache';
-}
-sub headers_out { shift }
-sub add { shift->{check} = \@_; }
-
-package Apache2::Faker;
-sub new { bless {}, shift }
-sub isa {
- my ($self, $pkg) = @_;
- return $pkg eq 'Apache2::RequestReq';
-}
-sub headers_out { shift }
-sub add { shift->{check} = \@_; }
+++ /dev/null
-#!/usr/local/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-use CGI ();
-use Config;
-
-my $loaded = 1;
-
-$| = 1;
-
-######################### End of black magic.
-
-# Set up a CGI environment
-$ENV{REQUEST_METHOD} = 'DELETE';
-$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull';
-$ENV{PATH_INFO} = '/somewhere/else';
-$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
-$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi';
-$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
-$ENV{SERVER_PORT} = 8080;
-$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
-$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}";
-$ENV{HTTP_LOVE} = 'true';
-
-my $q = new CGI;
-ok $q,"CGI::new()";
-is $q->request_method => 'DELETE',"CGI::request_method()";
-is $q->query_string => 'game=chess;game=checkers;weather=dull',"CGI::query_string()";
-is $q->param(), 2,"CGI::param()";
-is join(' ',sort $q->param()), 'game weather',"CGI::param()";
-is $q->param('game'), 'chess',"CGI::param()";
-is $q->param('weather'), 'dull',"CGI::param()";
-is join(' ',$q->param('game')), 'chess checkers',"CGI::param()";
-ok $q->param(-name=>'foo',-value=>'bar'),'CGI::param() put';
-is $q->param(-name=>'foo'), 'bar','CGI::param() get';
-is $q->query_string, 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux";
-is $q->http('love'), 'true',"CGI::http()";
-is $q->script_name, '/cgi-bin/foo.cgi',"CGI::script_name()";
-is $q->url, 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()";
-is $q->self_url,
- 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
- "CGI::url()";
-is $q->url(-absolute=>1), '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)';
-is $q->url(-relative=>1), 'foo.cgi','CGI::url(-relative=>1)';
-is $q->url(-relative=>1,-path=>1), 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)';
-is $q->url(-relative=>1,-path=>1,-query=>1),
- 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
- 'CGI::url(-relative=>1,-path=>1,-query=>1)';
-$q->delete('foo');
-ok !$q->param('foo'),'CGI::delete()';
-
-
-done_testing();
+++ /dev/null
-
-use strict;
-use warnings;
-
-use Test::More tests => 3;
-
-BEGIN { use_ok 'CGI', qw/ -compile :form / };
-
-is end_form() => '</form>', 'end_form()';
-is endform() => '</form>', 'endform()';
-
-
-
+++ /dev/null
-#!perl -w
-
-# Form-related tests for CGI.pm
-# If you are adding or updated tests, please put tests for each methods in
-# their own file, rather than growing this file any larger.
-
-use Test::More 'no_plan';
-use CGI (':standard','-no_debug','-tabindex');
-
-my $CRLF = "\015\012";
-if ($^O eq 'VMS') {
- $CRLF = "\n"; # via web server carriage is inserted automatically
-}
-if (ord("\t") != 9) { # EBCDIC?
- $CRLF = "\r\n";
-}
-
-
-# Set up a CGI environment
-$ENV{REQUEST_METHOD} = 'GET';
-$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull';
-$ENV{PATH_INFO} = '/somewhere/else';
-$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
-$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
-$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
-$ENV{SERVER_PORT} = 8080;
-$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
-
-is(start_form(-action=>'foobar',-method=>'get'),
- qq(<form method="get" action="foobar" enctype="multipart/form-data">),
- "start_form()");
-
-is(submit(),
- qq(<input type="submit" tabindex="1" name=".submit" />),
- "submit()");
-
-is(submit(-name => 'foo',
- -value => 'bar'),
- qq(<input type="submit" tabindex="2" name="foo" value="bar" />),
- "submit(-name,-value)");
-
-is(submit({-name => 'foo',
- -value => 'bar'}),
- qq(<input type="submit" tabindex="3" name="foo" value="bar" />),
- "submit({-name,-value})");
-
-is(textfield(-name => 'weather'),
- qq(<input type="text" name="weather" tabindex="4" value="dull" />),
- "textfield({-name})");
-
-is(textfield(-name => 'weather',
- -value => 'nice'),
- qq(<input type="text" name="weather" tabindex="5" value="dull" />),
- "textfield({-name,-value})");
-
-is(textfield(-name => 'weather',
- -value => 'nice',
- -override => 1),
- qq(<input type="text" name="weather" tabindex="6" value="nice" />),
- "textfield({-name,-value,-override})");
-
-is(checkbox(-name => 'weather',
- -value => 'nice'),
- qq(<label><input type="checkbox" name="weather" value="nice" tabindex="7" />weather</label>),
- "checkbox()");
-
-is(checkbox(-name => 'weather',
- -value => 'nice',
- -label => 'forecast'),
- qq(<label><input type="checkbox" name="weather" value="nice" tabindex="8" />forecast</label>),
- "checkbox()");
-
-is(checkbox(-name => 'weather',
- -value => 'nice',
- -label => 'forecast',
- -checked => 1,
- -override => 1),
- qq(<label><input type="checkbox" name="weather" value="nice" tabindex="9" checked="checked" />forecast</label>),
- "checkbox()");
-
-is(checkbox(-name => 'weather',
- -value => 'dull',
- -label => 'forecast'),
- qq(<label><input type="checkbox" name="weather" value="dull" tabindex="10" checked="checked" />forecast</label>),
- "checkbox()");
-
-is(radio_group(-name => 'game'),
- qq(<label><input type="radio" name="game" value="chess" checked="checked" tabindex="11" />chess</label> <label><input type="radio" name="game" value="checkers" tabindex="12" />checkers</label>),
- 'radio_group()');
-
-is(radio_group(-name => 'game',
- -labels => {'chess' => 'ping pong'}),
- qq(<label><input type="radio" name="game" value="chess" checked="checked" tabindex="13" />ping pong</label> <label><input type="radio" name="game" value="checkers" tabindex="14" />checkers</label>),
- 'radio_group()');
-
-is(checkbox_group(-name => 'game',
- -Values => [qw/checkers chess cribbage/]),
- qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" tabindex="15" />checkers</label> <label><input type="checkbox" name="game" value="chess" checked="checked" tabindex="16" />chess</label> <label><input type="checkbox" name="game" value="cribbage" tabindex="17" />cribbage</label>),
- 'checkbox_group()');
-
-is(checkbox_group(-name => 'game',
- '-values' => [qw/checkers chess cribbage/],
- '-defaults' => ['cribbage'],
- -override=>1),
- qq(<label><input type="checkbox" name="game" value="checkers" tabindex="18" />checkers</label> <label><input type="checkbox" name="game" value="chess" tabindex="19" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" tabindex="20" />cribbage</label>),
- 'checkbox_group()');
-
-is(popup_menu(-name => 'game',
- '-values' => [qw/checkers chess cribbage/],
- -default => 'cribbage',
- -override => 1),
- '<select name="game" tabindex="21" >
-<option value="checkers">checkers</option>
-<option value="chess">chess</option>
-<option selected="selected" value="cribbage">cribbage</option>
-</select>',
- 'popup_menu()');
-is(scrolling_list(-name => 'game',
- '-values' => [qw/checkers chess cribbage/],
- -default => 'cribbage',
- -override=>1),
- '<select name="game" tabindex="22" size="3">
-<option value="checkers">checkers</option>
-<option value="chess">chess</option>
-<option selected="selected" value="cribbage">cribbage</option>
-</select>',
- 'scrolling_list()');
-
-is(checkbox_group(-name => 'game',
- -Values => [qw/checkers chess cribbage/],
- -disabled => ['checkers']),
- qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" tabindex="23" disabled='1'/><span style="color:gray">checkers</span></label> <label><input type="checkbox" name="game" value="chess" checked="checked" tabindex="24" />chess</label> <label><input type="checkbox" name="game" value="cribbage" tabindex="25" />cribbage</label>),
- 'checkbox_group()');
-
-my $optgroup = optgroup(-name=>'optgroup_name',
- -Values => ['moe','catch'],
- -attributes=>{'catch'=>{'class'=>'red'}});
-
-is($optgroup,
- qq(<optgroup label="optgroup_name">
-<option value="moe">moe</option>
-<option class="red" value="catch">catch</option>
-</optgroup>),
- 'optgroup()');
-
-is(popup_menu(-name=>'menu_name',
- -Values=>[qw/eenie meenie minie/, $optgroup],
- -labels=>{'eenie'=>'one',
- 'meenie'=>'two',
- 'minie'=>'three'},
- -default=>'meenie'),
- qq(<select name="menu_name" tabindex="26" >
-<option value="eenie">one</option>
-<option selected="selected" value="meenie">two</option>
-<option value="minie">three</option>
-<optgroup label="optgroup_name">
-<option value="moe">moe</option>
-<option class="red" value="catch">catch</option>
-</optgroup>
-</select>),
- 'popup_menu() + optgroup()');
-
-is(scrolling_list(-name=>'menu_name',
- -Values=>[qw/eenie meenie minie/, $optgroup],
- -labels=>{'eenie'=>'one',
- 'meenie'=>'two',
- 'minie'=>'three'},
- -default=>'meenie'),
- qq(<select name="menu_name" tabindex="27" size="4">
-<option value="eenie">one</option>
-<option selected="selected" value="meenie">two</option>
-<option value="minie">three</option>
-<optgroup label="optgroup_name">
-<option value="moe">moe</option>
-<option class="red" value="catch">catch</option>
-</optgroup>
-</select>),
- 'scrolling_list() + optgroup()');
-
-# ---------- START 22046 ----------
-# The following tests were added for
-# https://rt.cpan.org/Public/Bug/Display.html?id=22046
-# SHCOREY at cpan.org
-# Saved whether working with XHTML because need to test both
-# with it and without.
-my $saved_XHTML = $CGI::XHTML;
-
-# set XHTML
-$CGI::XHTML = 1;
-
-is(start_form("GET","/foobar"),
- qq{<form method="get" action="/foobar" enctype="multipart/form-data">},
- 'start_form() + XHTML');
-
-is(start_form("GET", "/foobar",&CGI::URL_ENCODED),
- qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">},
- 'start_form() + XHTML + URL_ENCODED');
-
-is(start_form("GET", "/foobar",&CGI::MULTIPART),
- qq{<form method="get" action="/foobar" enctype="multipart/form-data">},
- 'start_form() + XHTML + MULTIPART');
-
-is(start_multipart_form("GET", "/foobar"),
- qq{<form method="get" action="/foobar" enctype="multipart/form-data">},
- 'start_multipart_form() + XHTML');
-
-is(start_multipart_form("GET", "/foobar","name=\"foobar\""),
- qq{<form method="get" action="/foobar" enctype="multipart/form-data" name="foobar">},
- 'start_multipart_form() + XHTML + additional args');
-
-# set no XHTML
-$CGI::XHTML = 0;
-
-is(start_form("GET","/foobar"),
- qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">},
- 'start_form() + NO_XHTML');
-
-is(start_form("GET", "/foobar",&CGI::URL_ENCODED),
- qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">},
- 'start_form() + NO_XHTML + URL_ENCODED');
-
-is(start_form("GET", "/foobar",&CGI::MULTIPART),
- qq{<form method="get" action="/foobar" enctype="multipart/form-data">},
- 'start_form() + NO_XHTML + MULTIPART');
-
-is(start_multipart_form("GET", "/foobar"),
- qq{<form method="get" action="/foobar" enctype="multipart/form-data">},
- 'start_multipart_form() + NO_XHTML');
-
-is(start_multipart_form("GET", "/foobar","name=\"foobar\""),
- qq{<form method="get" action="/foobar" enctype="multipart/form-data" name="foobar">},
- 'start_multipart_form() + NO_XHTML + additional args');
-
-# restoring value
-$CGI::XHTML = $saved_XHTML;
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-BEGIN {$| = 1; print "1..32\n"; }
-END {print "not ok 1\n" unless $loaded;}
-use Config;
-use CGI (':standard','keywords');
-$loaded = 1;
-$CGI::Util::SORT_ATTRIBUTES = 1;
-print "ok 1\n";
-
-######################### End of black magic.
-
-# util
-sub test {
- local($^W) = 0;
- my($num, $true,$msg) = @_;
- print($true ? "ok $num\n" : "not ok $num $msg\n");
-}
-
-my $CRLF = "\015\012";
-
-# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS
-# is that a CR character gets inserted automatically in the web server
-# case but not internal to perl's double quoted strings "\n". This
-# test would need to be modified to use the "\015\012" on VMS if it
-# were actually run through a web server.
-# Thanks to Peter Prymmer for this
-
-if ($^O eq 'VMS') { $CRLF = "\n"; }
-
-# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII
-# translation hence CRLF is used as \r\n within CGI.pm on such machines.
-
-if (ord("\t") != 9) { $CRLF = "\r\n"; }
-
-# Set up a CGI environment
-$ENV{REQUEST_METHOD}='GET';
-$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';
-$ENV{PATH_INFO} ='/somewhere/else';
-$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else';
-$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
-$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
-$ENV{SERVER_PORT} = 8080;
-$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
-$ENV{HTTP_LOVE} = 'true';
-
-test(2,request_method() eq 'GET',"CGI::request_method()");
-test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()");
-test(4,param() == 2,"CGI::param()");
-test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()");
-test(6,param('game') eq 'chess',"CGI::param()");
-test(7,param('weather') eq 'dull',"CGI::param()");
-test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()");
-test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put');
-test(10,param(-name=>'foo') eq 'bar','CGI::param() get');
-test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux");
-test(12,http('love') eq 'true',"CGI::http()");
-test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()");
-test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()");
-test(15,self_url() eq
- 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
- "CGI::url()");
-test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)');
-test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)');
-test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)');
-test(19,url(-relative=>1,-path=>1,-query=>1) eq
- 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
- 'CGI::url(-relative=>1,-path=>1,-query=>1)');
-Delete('foo');
-test(20,!param('foo'),'CGI::delete()');
-
-CGI::_reset_globals();
-$ENV{QUERY_STRING}='mary+had+a+little+lamb';
-test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords');
-test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords');
-
-CGI::_reset_globals;
-if ($Config{d_fork}) {
- $test_string = 'game=soccer&game=baseball&weather=nice';
- $ENV{REQUEST_METHOD}='POST';
- $ENV{CONTENT_LENGTH}=length($test_string);
- $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf';
- if (open(CHILD,"|-")) { # cparent
- print CHILD $test_string;
- close CHILD;
- exit 0;
- }
- # at this point, we're in a new (child) process
- test(23,param('weather') eq 'nice',"CGI::param() from POST");
- test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()");
-} else {
- print "ok 23 # Skip\n";
- print "ok 24 # Skip\n";
-}
-test(25,redirect('http://somewhere.else') eq "Status: 302 Found${CRLF}Location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1");
-my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html');
-test(26,$h eq "Status: 302 Found${CRLF}Location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
-test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Found${CRLF}Location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
-
-test(28,escapeHTML('CGI') eq 'CGI','escapeHTML(CGI) failing again');
-
-test(29, charset("UTF-8") && header() eq "Content-Type: text/html; charset=UTF-8${CRLF}${CRLF}", "UTF-8 charset");
-test(30, !charset("") && header() eq "Content-Type: text/html${CRLF}${CRLF}", "Empty charset");
-
-test(31, header(-foo=>'bar') eq "Foo: bar${CRLF}Content-Type: text/html${CRLF}${CRLF}", "Custom header");
-
-test(32, start_form(-action=>'one',name=>'two',onsubmit=>'three') eq qq(<form method="post" action="one" enctype="multipart/form-data" name="two" onsubmit="three">), "initial dash followed by undashed arguments")
+++ /dev/null
-
-# Test that header generation is spec compliant.
-# References:
-# http://www.w3.org/Protocols/rfc2616/rfc2616.html
-# http://www.w3.org/Protocols/rfc822/3_Lexical.html
-
-use strict;
-use warnings;
-
-use Test::More 'no_plan';
-
-use CGI;
-
-my $cgi = CGI->new;
-
-like $cgi->header( -type => "text/html" ),
- qr#Type: text/html#, 'known header, basic case: type => "text/html"';
-
-eval { $cgi->header( -type => "text/html".$CGI::CRLF."evil: stuff" ) };
-like($@,qr/contains a newline/,'invalid header blows up');
-
-like $cgi->header( -type => "text/html".$CGI::CRLF." evil: stuff " ),
- qr#Content-Type: text/html evil: stuff#, 'known header, with leading and trailing whitespace on the continuation line';
-
-eval { $cgi->header( -p3p => ["foo".$CGI::CRLF."bar"] ) };
-like($@,qr/contains a newline/,'P3P header with CRLF embedded blows up');
-
-eval { $cgi->header( -cookie => ["foo".$CGI::CRLF."bar"] ) };
-like($@,qr/contains a newline/,'Set-Cookie header with CRLF embedded blows up');
-
-eval { $cgi->header( -foobar => "text/html".$CGI::CRLF."evil: stuff" ) };
-like($@,qr/contains a newline/,'unknown header with CRLF embedded blows up');
-
-eval { $cgi->header( -foobar => $CGI::CRLF."Content-type: evil/header" ) };
-like($@,qr/contains a newline/, 'unknown header with leading newlines blows up');
-
-eval { $cgi->redirect( -type => "text/html".$CGI::CRLF."evil: stuff" ) };
-like($@,qr/contains a newline/,'redirect with known header with CRLF embedded blows up');
-
-eval { $cgi->redirect( -foobar => "text/html".$CGI::CRLF."evil: stuff" ) };
-like($@,qr/contains a newline/,'redirect with unknown header with CRLF embedded blows up');
-
-eval { $cgi->redirect( $CGI::CRLF.$CGI::CRLF."Content-Type: text/html") };
-like($@,qr/contains a newline/,'redirect with leading newlines blows up');
-
-{
- my $cgi = CGI->new('t=bogus%0A%0A<html>');
- my $out;
- eval { $out = $cgi->redirect( $cgi->param('t') ) };
- like($@,qr/contains a newline/, "redirect does not allow double-newline injection");
-}
-
-
+++ /dev/null
-#!perl -w
-
-use Test::More 'no_plan';
-use CGI;
-
-my $q = CGI->new;
-
-is( $q->hidden( 'hidden_name', 'foo' ),
- qq(<input type="hidden" name="hidden_name" value="foo" />),
- 'hidden() with single default value, positional');
-
-is( $q->hidden( -name => 'hidden_name', -default =>'foo' ),
- qq(<input type="hidden" name="hidden_name" value="foo" />),
- 'hidden() with single default value, named');
-
-is( $q->hidden( 'hidden_name', qw(foo bar baz fie) ),
- qq(<input type="hidden" name="hidden_name" value="foo" /><input type="hidden" name="hidden_name" value="bar" /><input type="hidden" name="hidden_name" value="baz" /><input type="hidden" name="hidden_name" value="fie" />),
- 'hidden() with default array, positional');
-
-is( $q->hidden( -name=>'hidden_name',
- -Values =>[qw/foo bar baz fie/],
- -Title => "hidden_field"),
- qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />),
- 'hidden() default array, named as "Values"');
-
-is( $q->hidden( -name=>'hidden_name',
- -default =>[qw/foo bar baz fie/],
- -Title => "hidden_field"),
- qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />),
- 'hidden() default array, named as "default"');
-
-is( $q->hidden( -name=>'hidden_name',
- '-value' =>[qw/foo bar baz fie/],
- -Title => "hidden_field"),
- qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />),
- 'hidden() default array, named as "value"');
-
-
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use Test::More tests => 33;
-
-END { ok $loaded; }
-use CGI ( ':standard', '-no_debug', '*h3', 'start_table' );
-$loaded = 1;
-$CGI::Util::SORT_ATTRIBUTES= 1;
-ok 1;
-
-BEGIN {
- $| = 1;
- if ( $] > 5.006 ) {
-
- # no utf8
- require utf8; # we contain Latin-1
- utf8->unimport;
- }
-}
-
-######################### End of black magic.
-
-my $CRLF = "\015\012";
-if ( $^O eq 'VMS' ) {
- $CRLF = "\n"; # via web server carriage is inserted automatically
-}
-if ( ord("\t") != 9 ) { # EBCDIC?
- $CRLF = "\r\n";
-}
-
-# util
-sub test {
- local ($^W) = 0;
- my ( undef, $true, $msg ) = @_;
- ok $true => $msg;
-}
-
-# all the automatic tags
-is h1(), '<h1 />', "single tag";
-
-is h1('fred'), '<h1>fred</h1>', "open/close tag";
-
-is h1( 'fred', 'agnes', 'maura' ), '<h1>fred agnes maura</h1>',
- "open/close tag multiple";
-
-is h1( { -align => 'CENTER' }, 'fred' ), '<h1 align="CENTER">fred</h1>',
- "open/close tag with attribute";
-
-is h1( { -align => undef }, 'fred' ), '<h1 align>fred</h1>',
- "open/close tag with orphan attribute";
-
-is h1( { -align => 'CENTER' }, [ 'fred', 'agnes' ] ),
- '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>',
- "distributive tag with attribute";
-
-{
- local $" = '-';
-
- is h1( 'fred', 'agnes', 'maura' ), '<h1>fred-agnes-maura</h1>',
- "open/close tag \$\" interpolation";
-
-}
-
-is header(), "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}",
- "header()";
-
-is header( -type => 'image/gif', -charset => '' ), "Content-Type: image/gif${CRLF}${CRLF}",
- "header()";
-
-is header( -type => 'image/gif', -status => '500 Sucks' ),
- "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}", "header()";
-
-# return to normal
-charset( 'ISO-8859-1' );
-
-like header( -nph => 1 ),
- qr!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,
- "header()";
-
-is start_html(), <<END, "start_html()";
-<!DOCTYPE html
- PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
-<head>
-<title>Untitled Document</title>
-<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
-</head>
-<body>
-END
-
-is start_html(
- -Title => 'The world of foo' ,
- -Script => [ {-src=> 'foo.js', -charset=>'utf-8'} ],
- ), <<END, "start_html()";
-<!DOCTYPE html
- PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
-<head>
-<title>The world of foo</title>
-<script charset="utf-8" src="foo.js" type="text/javascript"></script>
-<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
-</head>
-<body>
-END
-
-for my $v (qw/ 2.0 3.2 4.0 4.01 /) {
- local $CGI::XHTML = 1;
- is
- start_html( -dtd => "-//IETF//DTD HTML $v//FR", -lang => 'fr' ),
- <<"END", 'start_html()';
-<!DOCTYPE html
- PUBLIC "-//IETF//DTD HTML $v//FR">
-<html lang="fr"><head><title>Untitled Document</title>
-</head>
-<body>
-END
-}
-
-is
- start_html( -dtd => "-//IETF//DTD HTML 9.99//FR", -lang => 'fr' ),
- <<"END", 'start_html()';
-<!DOCTYPE html
- PUBLIC "-//IETF//DTD HTML 9.99//FR">
-<html xmlns="http://www.w3.org/1999/xhtml" lang="fr" xml:lang="fr">
-<head>
-<title>Untitled Document</title>
-<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
-</head>
-<body>
-END
-
-my $cookie =
- cookie( -name => 'fred', -value => [ 'chocolate', 'chip' ], -path => '/' );
-
-is $cookie, 'fred=chocolate&chip; path=/', "cookie()";
-
-my $h = header( -Cookie => $cookie );
-
-like $h,
- qr!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s,
- "header(-cookie)";
-
-is start_h3, '<h3>';
-
-is end_h3, '</h3>';
-
-is start_table( { -border => undef } ), '<table border>';
-is h1( escapeHTML("this is <not> \x8bright\x9b") ),
- '<h1>this is <not> ‹right›</h1>';
-
-charset('utf-8');
-
-is h1( escapeHTML("this is <not> \x8bright\x9b") ),
- ord("\t") == 9
- ? '<h1>this is <not> \8bright\9b</h1>'
- : '<h1>this is <not> »rightº</h1>';
-
-is i( p('hello there') ), '<i><p>hello there</p></i>';
-
-my $q = CGI->new;
-is $q->h1('hi'), '<h1>hi</h1>';
-
-$q->autoEscape(1);
-
-is $q->p( { title => "hello worldè" }, 'hello á' ),
- '<p title="hello world&egrave;">hello á</p>';
-
-$q->autoEscape(0);
-
-is $q->p( { title => "hello worldè" }, 'hello á' ),
- '<p title="hello worldè">hello á</p>';
-
-is p( { title => "hello worldè" }, 'hello á' ),
- '<p title="hello world&egrave;">hello á</p>';
-
-is header( -type => 'image/gif', -charset => 'UTF-8' ),
- "Content-Type: image/gif; charset=UTF-8${CRLF}${CRLF}", "header()";
+++ /dev/null
-#!./perl -w
-
-# Fixes RT 12909
-
-use lib qw(t/lib);
-
-use Test::More tests => 7;
-use CGI;
-
-my $cgi = CGI->new();
-
-{
- # http() without arguments should not cause warnings
- local $SIG{__WARN__} = sub { die @_ };
- ok eval { $cgi->http(); 1 }, "http() without arguments doesn't warn";
- ok eval { $cgi->https(); 1 }, "https() without arguments doesn't warn";
-}
-
-{
- # Capitalization and the use of hyphens versus underscores are not significant.
- local $ENV{'HTTP_HOST'} = 'foo';
- is $cgi->http('Host'), 'foo', 'http("Host") returns $ENV{HTTP_HOST}';
- is $cgi->http('http-host'), 'foo', 'http("http-host") returns $ENV{HTTP_HOST}';
-}
-
-{
- # Called with no arguments returns the list of HTTP environment variables
- local $ENV{'HTTPS_FOO'} = 'bar';
- my @http = $cgi->http();
- is scalar( grep /^HTTPS/, @http), 0, "http() doesn't return HTTPS variables";
-}
-
-{
- # https()
- # The same as http(), but operates on the HTTPS environment variables present when the SSL protocol is in
- # effect. Can be used to determine whether SSL is turned on.
- my @expect = grep /^HTTPS/, keys %ENV;
- push @expect, 'HTTPS' if not exists $ENV{HTTPS};
- push @expect, 'HTTPS_KEYSIZE' if not exists $ENV{HTTPS_KEYSIZE};
- local $ENV{'HTTPS'} = 'ON';
- local $ENV{'HTTPS_KEYSIZE'} = 512;
- is $cgi->https(), 'ON', 'scalar context to check SSL is on';
- ok eq_set( [$cgi->https()], \@expect), 'list context returns https keys';
-}
+++ /dev/null
-#!/usr/bin perl -w
-
-use strict;
-use Test::More tests => 1;
-
-use CGI;
-
-
-$_ = "abcdefghijklmnopq";
-my $IN;
-open ($IN, "t/init_test.txt");
-my $q = CGI->new($IN);
-is($_, 'abcdefghijklmnopq', 'make sure not to clobber $_ on init');
+++ /dev/null
-A=B
-D=F
-G=H
+++ /dev/null
-use Test::More 'no_plan';
-
-use CGI;
-
-my $q = CGI->new;
-
-my $sv = $q->multipart_init;
-like( $sv, qr|Content-Type: multipart/x-mixed-replace;boundary="------- =|, 'multipart_init(), basic');
-
-like( $sv, qr/$CGI::CRLF$/, 'multipart_init(), ends in CRLF' );
-
-$sv = $q->multipart_init( 'this_is_the_boundary' );
-like( $sv, qr/boundary="this_is_the_boundary"/, 'multipart_init("simple_boundary")' );
-$sv = $q->multipart_init( -boundary => 'this_is_another_boundary' );
-like($sv,
- qr/boundary="this_is_another_boundary"/, "multipart_init( -boundary => 'this_is_another_boundary')");
-
-{
- my $sv = $q->multipart_init;
- my $sv2 = $q->multipart_init;
- isnt($sv,$sv2,"due to random boundaries, multiple calls produce different results");
-}
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use Test::More tests => 18;
-
-BEGIN { use_ok('CGI'); };
-use CGI (':standard','-no_debug');
-
-my $CRLF = "\015\012";
-if ($^O eq 'VMS') {
- $CRLF = "\n"; # via web server carriage is inserted automatically
-}
-if (ord("\t") != 9) { # EBCDIC?
- $CRLF = "\r\n";
-}
-
-
-# Set up a CGI environment
-$ENV{REQUEST_METHOD} = 'GET';
-$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull';
-$ENV{PATH_INFO} = '/somewhere/else';
-$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
-$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
-$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
-$ENV{SERVER_PORT} = 8080;
-$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
-
-ok( (not $CGI::TABINDEX), "Tab index turned off.");
-
-is(submit(),
- qq(<input type="submit" name=".submit" />),
- "submit()");
-
-is(submit(-name => 'foo',
- -value => 'bar'),
- qq(<input type="submit" name="foo" value="bar" />),
- "submit(-name,-value)");
-
-is(submit({-name => 'foo',
- -value => 'bar'}),
- qq(<input type="submit" name="foo" value="bar" />),
- "submit({-name,-value})");
-
-is(textfield(-name => 'weather'),
- qq(<input type="text" name="weather" value="dull" />),
- "textfield({-name})");
-
-is(textfield(-name => 'weather',
- -value => 'nice'),
- qq(<input type="text" name="weather" value="dull" />),
- "textfield({-name,-value})");
-
-is(textfield(-name => 'weather',
- -value => 'nice',
- -override => 1),
- qq(<input type="text" name="weather" value="nice" />),
- "textfield({-name,-value,-override})");
-
-is(checkbox(-name => 'weather',
- -value => 'nice'),
- qq(<label><input type="checkbox" name="weather" value="nice" />weather</label>),
- "checkbox()");
-
-is(checkbox(-name => 'weather',
- -value => 'nice',
- -label => 'forecast'),
- qq(<label><input type="checkbox" name="weather" value="nice" />forecast</label>),
- "checkbox()");
-
-is(checkbox(-name => 'weather',
- -value => 'nice',
- -label => 'forecast',
- -checked => 1,
- -override => 1),
- qq(<label><input type="checkbox" name="weather" value="nice" checked="checked" />forecast</label>),
- "checkbox()");
-
-is(checkbox(-name => 'weather',
- -value => 'dull',
- -label => 'forecast'),
- qq(<label><input type="checkbox" name="weather" value="dull" checked="checked" />forecast</label>),
- "checkbox()");
-
-is(radio_group(-name => 'game'),
- qq(<label><input type="radio" name="game" value="chess" checked="checked" />chess</label> <label><input type="radio" name="game" value="checkers" />checkers</label>),
- 'radio_group()');
-
-is(radio_group(-name => 'game',
- -labels => {'chess' => 'ping pong'}),
- qq(<label><input type="radio" name="game" value="chess" checked="checked" />ping pong</label> <label><input type="radio" name="game" value="checkers" />checkers</label>),
- 'radio_group()');
-
-is(checkbox_group(-name => 'game',
- -Values => [qw/checkers chess cribbage/]),
- qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" />checkers</label> <label><input type="checkbox" name="game" value="chess" checked="checked" />chess</label> <label><input type="checkbox" name="game" value="cribbage" />cribbage</label>),
- 'checkbox_group()');
-
-is(checkbox_group(-name => 'game',
- '-values' => [qw/checkers chess cribbage/],
- '-defaults' => ['cribbage'],
- -override=>1),
- qq(<label><input type="checkbox" name="game" value="checkers" />checkers</label> <label><input type="checkbox" name="game" value="chess" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" />cribbage</label>),
- 'checkbox_group()');
-
-is(popup_menu(-name => 'game',
- '-values' => [qw/checkers chess cribbage/],
- -default => 'cribbage',
- -override => 1),
- '<select name="game" >
-<option value="checkers">checkers</option>
-<option value="chess">chess</option>
-<option selected="selected" value="cribbage">cribbage</option>
-</select>',
- 'popup_menu()');
-
-
-is(textarea(-name=>'foo',
- -default=>'starting value',
- -rows=>10,
- -columns=>50),
- '<textarea name="foo" rows="10" cols="50">starting value</textarea>',
- 'textarea()');
-
+++ /dev/null
-#!perl
-
-# Tests for the param_fetch() method.
-
-use Test::More 'no_plan';
-use CGI;
-
-{
- my $q = CGI->new('b=baz;a=foo;a=bar');
-
- is $q->param_fetch('a')->[0] => 'foo', 'first "a" is "foo"';
- is $q->param_fetch( -name => 'a' )->[0] => 'foo',
- 'first "a" is "foo", with -name';
- is $q->param_fetch('a')->[1] => 'bar', 'second "a" is "bar"';
- is_deeply $q->param_fetch('a') => [qw/ foo bar /], 'a is array ref';
- is_deeply $q->param_fetch( -name => 'a' ) => [qw/ foo bar /],
- 'a is array ref, w/ name';
-
- is $q->param_fetch('b')->[0] => 'baz', '"b" is "baz"';
- is_deeply $q->param_fetch('b') => [qw/ baz /], 'b is array ref too';
-
- is_deeply $q->param_fetch, [], "param_fetch without parameters";
-
- is_deeply $q->param_fetch( 'a', 'b' ), [qw/ foo bar /],
- "param_fetch only take first argument";
-}
+++ /dev/null
-#!perl
-# Tests for popup_menu();
-use Test::More 'no_plan';
-use CGI;
-
-my $q = CGI->new;
-
-is ( $q->popup_menu(-name=>"foo", - values=>[0,1], -default=>0),
-'<select name="foo" >
-<option selected="selected" value="0">0</option>
-<option value="1">1</option>
-</select>'
-, 'popup_menu(): basic test, including 0 as a default value');
-
-is(
- CGI::popup_menu(-values=>[CGI::optgroup(-values=>["b+"])],-default=>"b+"),
- '<select name="" >
-<optgroup label="">
-<option selected="selected" value="b+">b+</option>
-</optgroup>
-</select>'
- , "<optgroup> selections work when the default values contain regex characters (RT#49606)");
+++ /dev/null
-#!/bin/perl -w
-
-use strict;
-use Test::More tests => 17;
-use CGI::Pretty ':all';
-
-is(h1(), '<h1 />
-',"single tag");
-
-is(ol(li('fred'),li('ethel')), <<HTML, "basic indentation");
-<ol>
- <li>
- fred
- </li>
- <li>
- ethel
- </li>
-</ol>
-HTML
-
-
-is(p('hi',pre('there'),'frog'), <<HTML, "<pre> tags");
-<p>
- hi <pre>there</pre> frog
-</p>
-HTML
-
-is(h1({-align=>'CENTER'},'fred'), <<HTML, "open/close tag with attribute");
-<h1 align="CENTER">
- fred
-</h1>
-HTML
-
-is(h1({-align=>undef},'fred'), <<HTML,"open/close tag with orphan attribute");
-<h1 align>
- fred
-</h1>
-HTML
-
-is(h1({-align=>'CENTER'},['fred','agnes']), <<HTML, "distributive tag with attribute");
-<h1 align="CENTER">
- fred
-</h1>
-<h1 align="CENTER">
- agnes
-</h1>
-HTML
-
-is(p('hi',a({-href=>'frog'},'there'),'frog'), <<HTML, "as-is");
-<p>
- hi <a href="frog">there</a> frog
-</p>
-HTML
-
-is(p([ qw( hi there frog ) ] ), <<HTML, "array-reference");
-<p>
- hi
-</p>
-<p>
- there
-</p>
-<p>
- frog
-</p>
-HTML
-
-is(p(p(p('hi'), 'there' ), 'frog'), <<HTML, "nested tags");
-<p>
- <p>
- <p>
- hi
- </p>
- there
- </p>
- frog
-</p>
-HTML
-
-is(table(TR(td(table(TR(td('hi', 'there', 'frog')))))), <<HTML, "nested as-is tags");
-<table>
- <tr>
- <td><table>
- <tr>
- <td>hi there frog</td>
- </tr>
- </table></td>
- </tr>
-</table>
-HTML
-
-is(table(TR(td(table(TR(td( [ qw( hi there frog ) ])))))), <<HTML, "nested as-is array-reference");
-<table>
- <tr>
- <td><table>
- <tr>
- <td>hi</td><td>there</td><td>frog</td>
- </tr>
- </table></td>
- </tr>
-</table>
-HTML
-
-$CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
-
-is(h1(), '<h1 />',"single tag (pretty turned off)");
-is(h1('fred'), '<h1>fred</h1>',"open/close tag (pretty turned off)");
-is(h1('fred','agnes','maura'), '<h1>fred agnes maura</h1>',"open/close tag multiple (pretty turned off)");
-is(h1({-align=>'CENTER'},'fred'), '<h1 align="CENTER">fred</h1>',"open/close tag with attribute (pretty turned off)");
-is(h1({-align=>undef},'fred'), '<h1 align>fred</h1>',"open/close tag with orphan attribute (pretty turned off)");
-is(h1({-align=>'CENTER'},['fred','agnes']), '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>',
- "distributive tag with attribute (pretty turned off)");
-
+++ /dev/null
-#!./perl -wT
-
-use Test::More tests => 12;
-
-use_ok( 'CGI::Push' );
-
-ok( my $q = CGI::Push->new(), 'create a new CGI::Push object' );
-
-# test the simple_counter() method
-like( join('', $q->simple_counter(10)) , '/updated.+?10.+?times./', 'counter' );
-
-# test do_sleep, except we don't want to bog down the tests
-# there's also a potential timing-related failure lurking here
-# change this variable at your own risk
-my $sleep_in_tests = 0;
-
-SKIP: {
- skip( 'do_sleep() test may take a while', 1 ) unless $sleep_in_tests;
-
- my $time = time;
- CGI::Push::do_sleep(2);
- is(time - $time, 2, 'slept for a while' );
-}
-
-# test push_delay()
-ok( ! defined $q->push_delay(), 'no initial delay' );
-is( $q->push_delay(.5), .5, 'set a delay' );
-
-my $out = tie *STDOUT, 'TieOut';
-
-# next_page() to be called twice, last_page() once, no delay
-my %vars = (
- -next_page => sub { return if $_[1] > 2; 'next page' },
- -last_page => sub { 'last page' },
- -delay => 0,
-);
-
-$q->do_push(%vars);
-
-# this seems to appear on every page
-like( $$out, '/WARNING: YOUR BROWSER/', 'unsupported browser warning' );
-
-# these should appear correctly
-is( ($$out =~ s/next page//g), 2, 'next_page callback called appropriately' );
-is( ($$out =~ s/last page//g), 1, 'last_page callback called appropriately' );
-
-# send a fake content type (header capitalization varies in CGI, CGI::Push)
-$$out = '';
-$q->do_push(%vars, -type => 'fake' );
-like( $$out, '/Content-[Tt]ype: fake/', 'set custom Content-type' );
-
-# use our own counter, as $COUNTER in CGI::Push is now off
-my $i;
-$$out = '';
-
-# no delay, custom headers from callback, only call callback once
-$q->do_push(
- -delay => 0,
- -type => 'dynamic',
- -next_page => sub {
- return if $i++;
- return $_[0]->header('text/plain'), 'arduk';
- },
-);
-
-# header capitalization again, our word should appear only once
-like( $$out, '/ype: text\/plain/', 'set custom Content-type in next_page()' );
-is( $$out =~ s/arduk//g, 1, 'found text from next_page()' );
-
-package TieOut;
-
-sub TIEHANDLE {
- bless( \(my $text), $_[0] );
-}
-
-sub PRINT {
- my $self = shift;
- $$self .= join( $/, @_ );
-}
+++ /dev/null
-#!perl
-
-# Tests for the query_string() method.
-
-use Test::More 'no_plan';
-use CGI;
-
-{
- my $q1 = CGI->new('b=2;a=1;a=1');
- my $q2 = CGI->new('b=2&a=1&a=1');
-
- is($q1->query_string
- ,$q2->query_string
- , "query string format is returned with the same delimiter regardless of input.");
-}
+++ /dev/null
-#!/usr/local/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 41;
-
-use CGI ();
-use Config;
-
-my $loaded = 1;
-
-$| = 1;
-
-######################### End of black magic.
-
-# Set up a CGI environment
-$ENV{REQUEST_METHOD} = 'GET';
-$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull';
-$ENV{PATH_INFO} = '/somewhere/else';
-$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
-$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi';
-$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
-$ENV{SERVER_PORT} = 8080;
-$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
-$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}";
-$ENV{HTTP_LOVE} = 'true';
-
-my $q = new CGI;
-ok $q,"CGI::new()";
-is $q->request_method => 'GET',"CGI::request_method()";
-is $q->query_string => 'game=chess;game=checkers;weather=dull',"CGI::query_string()";
-is $q->param(), 2,"CGI::param()";
-is join(' ',sort $q->param()), 'game weather',"CGI::param()";
-is $q->param('game'), 'chess',"CGI::param()";
-is $q->param('weather'), 'dull',"CGI::param()";
-is join(' ',$q->param('game')), 'chess checkers',"CGI::param()";
-ok $q->param(-name=>'foo',-value=>'bar'),'CGI::param() put';
-is $q->param(-name=>'foo'), 'bar','CGI::param() get';
-is $q->query_string, 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux";
-is $q->http('love'), 'true',"CGI::http()";
-is $q->script_name, '/cgi-bin/foo.cgi',"CGI::script_name()";
-is $q->url, 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()";
-is $q->self_url,
- 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
- "CGI::url()";
-is $q->url(-absolute=>1), '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)';
-is $q->url(-relative=>1), 'foo.cgi','CGI::url(-relative=>1)';
-is $q->url(-relative=>1,-path=>1), 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)';
-is $q->url(-relative=>1,-path=>1,-query=>1),
- 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
- 'CGI::url(-relative=>1,-path=>1,-query=>1)';
-$q->delete('foo');
-ok !$q->param('foo'),'CGI::delete()';
-
-$q->_reset_globals;
-$ENV{QUERY_STRING}='mary+had+a+little+lamb';
-ok $q=new CGI,"CGI::new() redux";
-is join(' ',$q->keywords), 'mary had a little lamb','CGI::keywords';
-is join(' ',$q->param('keywords')), 'mary had a little lamb','CGI::keywords';
-ok $q=new CGI('foo=bar&foo=baz'),"CGI::new() redux";
-is $q->param('foo'), 'bar','CGI::param() redux';
-ok $q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2";
-is $q->param('bar'), 'froz',"CGI::param() redux 2";
-
-# test tied interface
-my $p = $q->Vars;
-is $p->{bar}, 'froz',"tied interface fetch";
-$p->{bar} = join("\0",qw(foo bar baz));
-is join(' ',$q->param('bar')), 'foo bar baz','tied interface store';
-ok exists $p->{bar};
-
-# test posting
-$q->_reset_globals;
-{
- my $test_string = 'game=soccer&game=baseball&weather=nice';
- local $ENV{REQUEST_METHOD}='POST';
- local $ENV{CONTENT_LENGTH}=length($test_string);
- local $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf';
-
- local *STDIN;
- open STDIN, '<', \$test_string;
-
- ok $q=new CGI,"CGI::new() from POST";
- is $q->param('weather'), 'nice',"CGI::param() from POST";
- is $q->url_param('big_balls'), 'basketball',"CGI::url_param()";
-}
-
-# test url_param
-{
- local $ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull';
-
- CGI::_reset_globals;
- my $q = CGI->new;
- # params present, param and url_param should return true
- ok $q->param, 'param() is true if parameters';
- ok $q->url_param, 'url_param() is true if parameters';
-
- $ENV{QUERY_STRING} = '';
-
- CGI::_reset_globals;
- $q = CGI->new;
- ok !$q->param, 'param() is false if no parameters';
- ok !$q->url_param, 'url_param() is false if no parameters';
-
- $ENV{QUERY_STRING} = 'tiger dragon';
- CGI::_reset_globals;
- $q = CGI->new;
-
- is_deeply [$q->$_] => [ 'keywords' ], "$_ with QS='$ENV{QUERY_STRING}'"
- for qw/ param url_param /;
-
- is_deeply [ sort $q->$_( 'keywords' ) ], [ qw/ dragon tiger / ],
- "$_ keywords" for qw/ param url_param /;
-}
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More tests => 1; # last test to print
-
-use CGI;
-
-$ENV{REQUEST_METHOD} = 'PUT';
-
-my $cgi = CGI->new;
-
-pass 'new() returned';
-
-
+++ /dev/null
-
-use strict;
-use warnings;
-
-# Reference: RT#13158: Needs test: empty name/value, when saved, prevents proper restore from filehandle.
-# https://rt.cpan.org/Ticket/Display.html?id=13158
-
-use Test::More tests => 3;
-
-use IO::File;
-use CGI;
-
-my $cgi = CGI->new('a=1;=;b=2;=3');
-ok eq_set (['a', '', 'b'], [$cgi->param]);
-
-# not File::Temp, since that wasn't in core at 5.6.0
-my $tmp = IO::File->new_tmpfile;
-$cgi->save($tmp);
-$tmp->seek(0,0);
-
-$cgi = CGI->new($tmp);
-ok eq_set (['a', '', 'b'], [$cgi->param]);
-is $cgi->param(''), 3; # '=' is lost, '=3' is retained
-
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use lib qw(t/lib);
-use strict;
-
-# Due to a bug in older versions of MakeMaker & Test::Harness, we must
-# ensure the blib's are in @INC, else we might use the core CGI.pm
-use lib qw(blib/lib blib/arch);
-use Test::More tests => 45;
-
-use CGI qw(:standard *h1 *h2 *h3 *h4 *h5 *h6 *table *ul *li *ol *td *b *i *u *div);
-
-is(start_h1(), "<h1>", "start_h1"); # TEST
-is(start_h1({class => 'hello'}), "<h1 class=\"hello\">", "start_h1 with param"); # TEST
-is(end_h1(), "</h1>", "end_h1"); # TEST
-
-is(start_h2(), "<h2>", "start_h2"); # TEST
-is(start_h2({class => 'hello'}), "<h2 class=\"hello\">", "start_h2 with param"); # TEST
-is(end_h2(), "</h2>", "end_h2"); # TEST
-
-is(start_h3(), "<h3>", "start_h3"); # TEST
-is(start_h3({class => 'hello'}), "<h3 class=\"hello\">", "start_h3 with param"); # TEST
-is(end_h3(), "</h3>", "end_h3"); # TEST
-
-is(start_h4(), "<h4>", "start_h4"); # TEST
-is(start_h4({class => 'hello'}), "<h4 class=\"hello\">", "start_h4 with param"); # TEST
-is(end_h4(), "</h4>", "end_h4"); # TEST
-
-is(start_h5(), "<h5>", "start_h5"); # TEST
-is(start_h5({class => 'hello'}), "<h5 class=\"hello\">", "start_h5 with param"); # TEST
-is(end_h5(), "</h5>", "end_h5"); # TEST
-
-is(start_h6(), "<h6>", "start_h6"); # TEST
-is(start_h6({class => 'hello'}), "<h6 class=\"hello\">", "start_h6 with param"); # TEST
-is(end_h6(), "</h6>", "end_h6"); # TEST
-
-is(start_table(), "<table>", "start_table"); # TEST
-is(start_table({class => 'hello'}), "<table class=\"hello\">", "start_table with param"); # TEST
-is(end_table(), "</table>", "end_table"); # TEST
-
-is(start_ul(), "<ul>", "start_ul"); # TEST
-is(start_ul({class => 'hello'}), "<ul class=\"hello\">", "start_ul with param"); # TEST
-is(end_ul(), "</ul>", "end_ul"); # TEST
-
-is(start_li(), "<li>", "start_li"); # TEST
-is(start_li({class => 'hello'}), "<li class=\"hello\">", "start_li with param"); # TEST
-is(end_li(), "</li>", "end_li"); # TEST
-
-is(start_ol(), "<ol>", "start_ol"); # TEST
-is(start_ol({class => 'hello'}), "<ol class=\"hello\">", "start_ol with param"); # TEST
-is(end_ol(), "</ol>", "end_ol"); # TEST
-
-is(start_td(), "<td>", "start_td"); # TEST
-is(start_td({class => 'hello'}), "<td class=\"hello\">", "start_td with param"); # TEST
-is(end_td(), "</td>", "end_td"); # TEST
-
-is(start_b(), "<b>", "start_b"); # TEST
-is(start_b({class => 'hello'}), "<b class=\"hello\">", "start_b with param"); # TEST
-is(end_b(), "</b>", "end_b"); # TEST
-
-is(start_i(), "<i>", "start_i"); # TEST
-is(start_i({class => 'hello'}), "<i class=\"hello\">", "start_i with param"); # TEST
-is(end_i(), "</i>", "end_i"); # TEST
-
-is(start_u(), "<u>", "start_u"); # TEST
-is(start_u({class => 'hello'}), "<u class=\"hello\">", "start_u with param"); # TEST
-is(end_u(), "</u>", "end_u"); # TEST
-
-is(start_div(), "<div>", "start_div"); # TEST
-is(start_div({class => 'hello'}), "<div class=\"hello\">", "start_div with param"); # TEST
-is(end_div(), "</div>", "end_div"); # TEST
-
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use lib qw(t/lib);
-use strict;
-
-# Due to a bug in older versions of MakeMaker & Test::Harness, we must
-# ensure the blib's are in @INC, else we might use the core CGI.pm
-use lib qw(blib/lib blib/arch);
-use Test::More tests => 45;
-
-use CGI qw(:standard end_h1 end_h2 end_h3 end_h4 end_h5 end_h6 end_table end_ul end_li end_ol end_td end_b end_i end_u end_div);
-
-is(start_h1(), "<h1>", "start_h1"); # TEST
-is(start_h1({class => 'hello'}), "<h1 class=\"hello\">", "start_h1 with param"); # TEST
-is(end_h1(), "</h1>", "end_h1"); # TEST
-
-is(start_h2(), "<h2>", "start_h2"); # TEST
-is(start_h2({class => 'hello'}), "<h2 class=\"hello\">", "start_h2 with param"); # TEST
-is(end_h2(), "</h2>", "end_h2"); # TEST
-
-is(start_h3(), "<h3>", "start_h3"); # TEST
-is(start_h3({class => 'hello'}), "<h3 class=\"hello\">", "start_h3 with param"); # TEST
-is(end_h3(), "</h3>", "end_h3"); # TEST
-
-is(start_h4(), "<h4>", "start_h4"); # TEST
-is(start_h4({class => 'hello'}), "<h4 class=\"hello\">", "start_h4 with param"); # TEST
-is(end_h4(), "</h4>", "end_h4"); # TEST
-
-is(start_h5(), "<h5>", "start_h5"); # TEST
-is(start_h5({class => 'hello'}), "<h5 class=\"hello\">", "start_h5 with param"); # TEST
-is(end_h5(), "</h5>", "end_h5"); # TEST
-
-is(start_h6(), "<h6>", "start_h6"); # TEST
-is(start_h6({class => 'hello'}), "<h6 class=\"hello\">", "start_h6 with param"); # TEST
-is(end_h6(), "</h6>", "end_h6"); # TEST
-
-is(start_table(), "<table>", "start_table"); # TEST
-is(start_table({class => 'hello'}), "<table class=\"hello\">", "start_table with param"); # TEST
-is(end_table(), "</table>", "end_table"); # TEST
-
-is(start_ul(), "<ul>", "start_ul"); # TEST
-is(start_ul({class => 'hello'}), "<ul class=\"hello\">", "start_ul with param"); # TEST
-is(end_ul(), "</ul>", "end_ul"); # TEST
-
-is(start_li(), "<li>", "start_li"); # TEST
-is(start_li({class => 'hello'}), "<li class=\"hello\">", "start_li with param"); # TEST
-is(end_li(), "</li>", "end_li"); # TEST
-
-is(start_ol(), "<ol>", "start_ol"); # TEST
-is(start_ol({class => 'hello'}), "<ol class=\"hello\">", "start_ol with param"); # TEST
-is(end_ol(), "</ol>", "end_ol"); # TEST
-
-is(start_td(), "<td>", "start_td"); # TEST
-is(start_td({class => 'hello'}), "<td class=\"hello\">", "start_td with param"); # TEST
-is(end_td(), "</td>", "end_td"); # TEST
-
-is(start_b(), "<b>", "start_b"); # TEST
-is(start_b({class => 'hello'}), "<b class=\"hello\">", "start_b with param"); # TEST
-is(end_b(), "</b>", "end_b"); # TEST
-
-is(start_i(), "<i>", "start_i"); # TEST
-is(start_i({class => 'hello'}), "<i class=\"hello\">", "start_i with param"); # TEST
-is(end_i(), "</i>", "end_i"); # TEST
-
-is(start_u(), "<u>", "start_u"); # TEST
-is(start_u({class => 'hello'}), "<u class=\"hello\">", "start_u with param"); # TEST
-is(end_u(), "</u>", "end_u"); # TEST
-
-is(start_div(), "<div>", "start_div"); # TEST
-is(start_div({class => 'hello'}), "<div class=\"hello\">", "start_div with param"); # TEST
-is(end_div(), "</div>", "end_div"); # TEST
-
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use lib qw(t/lib);
-use strict;
-
-# Due to a bug in older versions of MakeMaker & Test::Harness, we must
-# ensure the blib's are in @INC, else we might use the core CGI.pm
-use lib qw(blib/lib blib/arch);
-use Test::More tests => 45;
-
-use CGI qw(:standard start_h1 start_h2 start_h3 start_h4 start_h5 start_h6 start_table start_ul start_li start_ol start_td start_b start_i start_u start_div);
-
-is(start_h1(), "<h1>", "start_h1"); # TEST
-is(start_h1({class => 'hello'}), "<h1 class=\"hello\">", "start_h1 with param"); # TEST
-is(end_h1(), "</h1>", "end_h1"); # TEST
-
-is(start_h2(), "<h2>", "start_h2"); # TEST
-is(start_h2({class => 'hello'}), "<h2 class=\"hello\">", "start_h2 with param"); # TEST
-is(end_h2(), "</h2>", "end_h2"); # TEST
-
-is(start_h3(), "<h3>", "start_h3"); # TEST
-is(start_h3({class => 'hello'}), "<h3 class=\"hello\">", "start_h3 with param"); # TEST
-is(end_h3(), "</h3>", "end_h3"); # TEST
-
-is(start_h4(), "<h4>", "start_h4"); # TEST
-is(start_h4({class => 'hello'}), "<h4 class=\"hello\">", "start_h4 with param"); # TEST
-is(end_h4(), "</h4>", "end_h4"); # TEST
-
-is(start_h5(), "<h5>", "start_h5"); # TEST
-is(start_h5({class => 'hello'}), "<h5 class=\"hello\">", "start_h5 with param"); # TEST
-is(end_h5(), "</h5>", "end_h5"); # TEST
-
-is(start_h6(), "<h6>", "start_h6"); # TEST
-is(start_h6({class => 'hello'}), "<h6 class=\"hello\">", "start_h6 with param"); # TEST
-is(end_h6(), "</h6>", "end_h6"); # TEST
-
-is(start_table(), "<table>", "start_table"); # TEST
-is(start_table({class => 'hello'}), "<table class=\"hello\">", "start_table with param"); # TEST
-is(end_table(), "</table>", "end_table"); # TEST
-
-is(start_ul(), "<ul>", "start_ul"); # TEST
-is(start_ul({class => 'hello'}), "<ul class=\"hello\">", "start_ul with param"); # TEST
-is(end_ul(), "</ul>", "end_ul"); # TEST
-
-is(start_li(), "<li>", "start_li"); # TEST
-is(start_li({class => 'hello'}), "<li class=\"hello\">", "start_li with param"); # TEST
-is(end_li(), "</li>", "end_li"); # TEST
-
-is(start_ol(), "<ol>", "start_ol"); # TEST
-is(start_ol({class => 'hello'}), "<ol class=\"hello\">", "start_ol with param"); # TEST
-is(end_ol(), "</ol>", "end_ol"); # TEST
-
-is(start_td(), "<td>", "start_td"); # TEST
-is(start_td({class => 'hello'}), "<td class=\"hello\">", "start_td with param"); # TEST
-is(end_td(), "</td>", "end_td"); # TEST
-
-is(start_b(), "<b>", "start_b"); # TEST
-is(start_b({class => 'hello'}), "<b class=\"hello\">", "start_b with param"); # TEST
-is(end_b(), "</b>", "end_b"); # TEST
-
-is(start_i(), "<i>", "start_i"); # TEST
-is(start_i({class => 'hello'}), "<i class=\"hello\">", "start_i with param"); # TEST
-is(end_i(), "</i>", "end_i"); # TEST
-
-is(start_u(), "<u>", "start_u"); # TEST
-is(start_u({class => 'hello'}), "<u class=\"hello\">", "start_u with param"); # TEST
-is(end_u(), "</u>", "end_u"); # TEST
-
-is(start_div(), "<div>", "start_div"); # TEST
-is(start_div({class => 'hello'}), "<div class=\"hello\">", "start_div with param"); # TEST
-is(end_div(), "</div>", "end_div"); # TEST
-
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use strict;
-use Test::More tests => 1;
-
-# Can't do much with this other than make sure it loads properly
-BEGIN { use_ok('CGI::Switch') };
+++ /dev/null
-#!perl
-use Test::More;
-use strict;
-
-if( $> == 0 ) {
- plan skip_all => "Root can write to 'unwritable files', so many of these tests don't make sense for root.";
-}
-
-my ($testdir, $testdir2);
-
-BEGIN {
- $testdir = "CGItest";
- $testdir2 = "CGItest2";
- for ($testdir, $testdir2) {
- ( -d ) || mkdir $_;
- ( ! -w ) || chmod 0700, $_;
- }
- $CGITempFile::TMPDIRECTORY = $testdir;
- $ENV{TMPDIR} = $testdir2;
-}
-
-use CGI;
-is($CGITempFile::TMPDIRECTORY, $testdir, "can pre-set \$CGITempFile::TMPDIRECTORY");
-CGITempFile->new;
-is($CGITempFile::TMPDIRECTORY, $testdir, "\$CGITempFile::TMPDIRECTORY unchanged");
-
-ok(chmod 0500, $testdir, "revoking write access to $testdir");
-ok(! -w $testdir, "write access to $testdir revoked");
-CGITempFile->new;
-is($CGITempFile::TMPDIRECTORY, $testdir2,
- "unwritable \$CGITempFile::TMPDIRECTORY overridden");
-
-ok(chmod 0500, $testdir2, "revoking write access to $testdir2");
-ok(! -w $testdir, "write access to $testdir revoked");
-CGITempFile->new;
-isnt($CGITempFile::TMPDIRECTORY, $testdir2,
- "unwritable \$ENV{TMPDIR} overridden");
-isnt($CGITempFile::TMPDIRECTORY, $testdir,
- "unwritable \$ENV{TMPDIR} not overridden with an unwritable \$CGITempFile::TMPDIRECTORY");
-
-done_testing();
-
-END { for ($testdir, $testdir2) { chmod 0700, $_; rmdir; } }
+++ /dev/null
-use Test::More tests => 6;
-use CGI 'unescapeHTML';
-
-is( unescapeHTML( '&'), '&', 'unescapeHTML: &');
-is( unescapeHTML( '"'), '"', 'unescapeHTML: "');
-is( unescapeHTML( '<'), '<', 'unescapeHTML: < (using a numbered sequence)');
-is( unescapeHTML( 'Bob & Tom went to the store; Where did you go?'),
- 'Bob & Tom went to the store; Where did you go?', 'unescapeHTML: a case where &...; should not be escaped.');
-is( unescapeHTML( 'This_string_contains_both_escaped_&_unescaped_<entities>'),
- 'This_string_contains_both_escaped_&_unescaped_<entities>', 'unescapeHTML: partially-escaped string.');
-is( unescapeHTML( 'This escaped string kind of looks like it has an escaped entity &x; it does not'),
- 'This escaped string kind of looks like it has an escaped entity &x; it does not', 'unescapeHTML: Another case where &...; should not be escaped.');
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-#################################################################
-# Emanuele Zeppieri, Mark Stosberg #
-# Shamelessly stolen from Data::FormValidator and CGI::Upload #
-#################################################################
-
-use strict;
-
-use Test::More 'no_plan';
-
-use CGI;
-
-#-----------------------------------------------------------------------------
-# %ENV setup.
-#-----------------------------------------------------------------------------
-
-my %myenv;
-
-BEGIN {
- %myenv = (
- 'SCRIPT_NAME' => '/test.cgi',
- 'SERVER_NAME' => 'perl.org',
- 'HTTP_CONNECTION' => 'TE, close',
- 'REQUEST_METHOD' => 'POST',
- 'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
- 'CONTENT_LENGTH' => 3285,
- 'SCRIPT_FILENAME' => '/home/usr/test.cgi',
- 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
- 'HTTP_TE' => 'deflate,gzip;q=0.3',
- 'QUERY_STRING' => '',
- 'REMOTE_PORT' => '1855',
- 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
- 'SERVER_PORT' => '80',
- 'REMOTE_ADDR' => '127.0.0.1',
- 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
- 'SERVER_PROTOCOL' => 'HTTP/1.1',
- 'PATH' => '/usr/local/bin:/usr/bin:/bin',
- 'REQUEST_URI' => '/test.cgi',
- 'GATEWAY_INTERFACE' => 'CGI/1.1',
- 'SCRIPT_URL' => '/test.cgi',
- 'SERVER_ADDR' => '127.0.0.1',
- 'DOCUMENT_ROOT' => '/home/develop',
- 'HTTP_HOST' => 'www.perl.org'
- );
-
- for my $key (keys %myenv) {
- $ENV{$key} = $myenv{$key};
- }
-}
-
-END {
- for my $key (keys %myenv) {
- delete $ENV{$key};
- }
-}
-
-#-----------------------------------------------------------------------------
-# Simulate the upload (really, multiple uploads contained in a single stream).
-#-----------------------------------------------------------------------------
-
-my $q;
-
-{
- local *STDIN;
- open STDIN, '<t/upload_post_text.txt'
- or die 'missing test file t/upload_post_text.txt';
- binmode STDIN;
- $q = CGI->new;
-}
-
-#-----------------------------------------------------------------------------
-# Check that the file names retrieved by CGI are correct.
-#-----------------------------------------------------------------------------
-
-is( $q->param('does_not_exist_gif'), 'does_not_exist.gif', 'filename_2' );
-is( $q->param('100;100_gif') , '100;100.gif' , 'filename_3' );
-is( $q->param('300x300_gif') , '300x300.gif' , 'filename_4' );
-
-{
- my $test = "multiple file names are handled right with same-named upload fields";
- my @hello_names = $q->param('hello_world');
- is ($hello_names[0],'goodbye_world.txt',$test. "...first file");
- is ($hello_names[1],'hello_world.txt',$test. "...second file");
-}
-
-#-----------------------------------------------------------------------------
-# Now check that the upload method works.
-#-----------------------------------------------------------------------------
-
-ok( defined $q->upload('does_not_exist_gif'), 'upload_basic_2' );
-ok( defined $q->upload('100;100_gif') , 'upload_basic_3' );
-ok( defined $q->upload('300x300_gif') , 'upload_basic_4' );
-
-{
- my $test = "file handles have expected length for multi-valued field. ";
- my ($goodbye_fh,$hello_fh) = $q->upload('hello_world');
-
- # Go to end of file;
- seek($goodbye_fh,0,2);
- # How long is the file?
- is(tell($goodbye_fh), 15, "$test..first file");
-
- # Go to end of file;
- seek($hello_fh,0,2);
- # How long is the file?
- is(tell($hello_fh), 13, "$test..second file");
-
-}
-
-
-
-{
- my $test = "300x300_gif has expected length";
- my $fh1 = $q->upload('300x300_gif');
- is(tell($fh1), 0, "First object: filehandle starts with position set at zero");
-
- # Go to end of file;
- seek($fh1,0,2);
- # How long is the file?
- is(tell($fh1), 1656, $test);
-}
-
-my $q2 = CGI->new;
-
-{
- my $test = "Upload filehandles still work after calling CGI->new a second time";
- $q->param('new','zoo');
-
- is($q2->param('new'),undef,
- "Reality Check: params set in one object instance don't appear in another instance");
-
- my $fh2 = $q2->upload('300x300_gif');
- is(tell($fh2), 0, "...so the state of a file handle shouldn't be carried to a new object instance, either.");
- # Go to end of file;
- seek($fh2,0,2);
- # How long is the file?
- is(tell($fh2), 1656, $test);
-}
-
-{
- my $test = "multi-valued uploads are reset properly";
- my ($dont_care, $hello_fh2) = $q2->upload('hello_world');
- is(tell($hello_fh2), 0, $test);
-}
-
-# vim: nospell
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-#################################################################
-# Emanuele Zeppieri, Mark Stosberg #
-# Shamelessly stolen from Data::FormValidator and CGI::Upload #
-#################################################################
-
-use strict;
-use Test::More 'no_plan';
-
-use CGI;
-
-#-----------------------------------------------------------------------------
-# %ENV setup.
-#-----------------------------------------------------------------------------
-
-my %myenv;
-
-BEGIN {
- %myenv = (
- 'SCRIPT_NAME' => '/test.cgi',
- 'SERVER_NAME' => 'perl.org',
- 'HTTP_CONNECTION' => 'TE, close',
- 'REQUEST_METHOD' => 'POST',
- 'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
- 'CONTENT_LENGTH' => 3285,
- 'SCRIPT_FILENAME' => '/home/usr/test.cgi',
- 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
- 'HTTP_TE' => 'deflate,gzip;q=0.3',
- 'QUERY_STRING' => '',
- 'REMOTE_PORT' => '1855',
- 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
- 'SERVER_PORT' => '80',
- 'REMOTE_ADDR' => '127.0.0.1',
- 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
- 'SERVER_PROTOCOL' => 'HTTP/1.1',
- 'PATH' => '/usr/local/bin:/usr/bin:/bin',
- 'REQUEST_URI' => '/test.cgi',
- 'GATEWAY_INTERFACE' => 'CGI/1.1',
- 'SCRIPT_URL' => '/test.cgi',
- 'SERVER_ADDR' => '127.0.0.1',
- 'DOCUMENT_ROOT' => '/home/develop',
- 'HTTP_HOST' => 'www.perl.org'
- );
-
- for my $key (keys %myenv) {
- $ENV{$key} = $myenv{$key};
- }
-}
-
-END {
- for my $key (keys %myenv) {
- delete $ENV{$key};
- }
-}
-
-
-#-----------------------------------------------------------------------------
-# Simulate the upload (really, multiple uploads contained in a single stream).
-#-----------------------------------------------------------------------------
-
-my $q;
-
-{
- local *STDIN;
- open STDIN, '<t/upload_post_text.txt'
- or die 'missing test file t/upload_post_text.txt';
- binmode STDIN;
- $q = CGI->new;
-}
-
-{
- my $test = "uploadInfo: basic test";
- my $fh = $q->upload('300x300_gif');
- is( $q->uploadInfo($fh)->{'Content-Type'}, "image/gif", $test);
-}
-
-my $q2 = CGI->new;
-
-{
- my $test = "uploadInfo: works with second object instance";
- my $fh = $q2->upload('300x300_gif');
- is( $q2->uploadInfo($fh)->{'Content-Type'}, "image/gif", $test);
-}
-
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-
-use CGI ':all';
-
-
-$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:8484';
-$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
-$ENV{SERVER_PORT} = 8080;
-$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
-
-is virtual_port() => 8484, 'virtual_port()';
-is server_port() => 8080, 'server_port()';
-
-is url() => 'http://proxy:8484', 'url()';
-
-# let's see if we do the defaults right
-
-$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:80';
-
-is url() => 'http://proxy', 'url() with default port';
-
-subtest 'rewrite_interactions' => sub {
- # Reference: RT#45019
-
- local $ENV{HTTP_X_FORWARDED_HOST} = undef;
- local $ENV{SERVER_PROTOCOL} = undef;
- local $ENV{SERVER_PORT} = undef;
- local $ENV{SERVER_NAME} = undef;
-
- # These two are always set
- local $ENV{'SCRIPT_NAME'} = '/real/cgi-bin/dispatch.cgi';
- local $ENV{'SCRIPT_FILENAME'} = '/home/mark/real/path/cgi-bin/dispatch.cgi';
-
- # These two are added by mod_rewrite Ref: http://httpd.apache.org/docs/2.2/mod/mod_rewrite.html
-
- local $ENV{'SCRIPT_URL'} = '/real/path/info';
- local $ENV{'SCRIPT_URI'} = 'http://example.com/real/path/info';
-
- local $ENV{'PATH_INFO'} = '/path/info';
- local $ENV{'REQUEST_URI'} = '/real/path/info';
- local $ENV{'HTTP_HOST'} = 'example.com';
-
- my $q = CGI->new;
-
- is(
- $q->url( -absolute => 1, -query => 1, -path_info => 1 ),
- '/real/path/info',
- '$q->url( -absolute => 1, -query => 1, -path_info => 1 ) should return complete path, even when mod_rewrite is detected.'
- );
- is( $q->url(), 'http://example.com/real', '$q->url(), with rewriting detected' );
- is( $q->url(-full=>1), 'http://example.com/real', '$q->url(-full=>1), with rewriting detected' );
- is( $q->url(-path=>1), 'http://example.com/real/path/info', '$q->url(-path=>1), with rewriting detected' );
- is( $q->url(-path=>0), 'http://example.com/real', '$q->url(-path=>0), with rewriting detected' );
- is( $q->url(-full=>1,-path=>1), 'http://example.com/real/path/info', '$q->url(-full=>1,-path=>1), with rewriting detected' );
- is( $q->url(-rewrite=>1,-path=>0), 'http://example.com/real', '$q->url(-rewrite=>1,-path=>0), with rewriting detected' );
- is( $q->url(-rewrite=>1), 'http://example.com/real',
- '$q->url(-rewrite=>1), with rewriting detected' );
- is( $q->url(-rewrite=>0), 'http://example.com/real/cgi-bin/dispatch.cgi',
- '$q->url(-rewrite=>0), with rewriting detected' );
- is( $q->url(-rewrite=>0,-path=>1), 'http://example.com/real/cgi-bin/dispatch.cgi/path/info',
- '$q->url(-rewrite=>0,-path=>1), with rewriting detected' );
- is( $q->url(-rewrite=>1,-path=>1), 'http://example.com/real/path/info',
- '$q->url(-rewrite=>1,-path=>1), with rewriting detected' );
- is( $q->url(-rewrite=>0,-path=>0), 'http://example.com/real/cgi-bin/dispatch.cgi',
- '$q->url(-rewrite=>0,-path=>1), with rewriting detected' );
-};
-
-subtest 'RT#58377: + in PATH_INFO' => sub {
- local $ENV{PATH_INFO} = '/hello+world';
- local $ENV{HTTP_X_FORWARDED_HOST} = undef;
- local $ENV{'HTTP_HOST'} = 'example.com';
- local $ENV{'SCRIPT_NAME'} = '/script/plus+name.cgi';
- local $ENV{'SCRIPT_FILENAME'} = '/script/plus+filename.cgi';
-
- my $q = CGI->new;
- is($q->url(), 'http://example.com/script/plus+name.cgi', 'a plus sign in a script name is preserved when calling url()');
- is($q->path_info(), '/hello+world', 'a plus sign in a script name is preserved when calling path_info()');
-};
-
-
-done_testing();
-
-
+++ /dev/null
-# Test the user_agent method.
-use Test::More 'no_plan';
-use CGI;
-
-my $q = CGI->new;
-
-is($q->user_agent, undef, 'user_agent: undef test');
-
-$ENV{HTTP_USER_AGENT} = 'mark';
-is($q->user_agent, 'mark', 'user_agent: basic test');
-ok($q->user_agent('ma.*'), 'user_agent: positive regex test');
-ok(!$q->user_agent('BOOM.*'), 'user_agent: negative regex test');
-
-
+++ /dev/null
-#!perl -T
-
-use strict;
-use warnings;
-
-use utf8;
-
-use Test::More tests => 7;
-use Encode;
-
-use_ok( 'CGI' );
-
-ok( my $q = CGI->new, 'create a new CGI object' );
-
-{
- no warnings qw/ once /;
- $CGI::PARAM_UTF8 = 1;
-}
-
-my $data = 'áéíóúµ';
-ok Encode::is_utf8($data), "created UTF-8 encoded data string";
-
-# now set the param.
-$q->param(data => $data);
-
-# if param() runs the data through Encode::decode(), this will fail.
-is $q->param('data'), $data;
-
-# make sure setting bytes decodes properly
-my $bytes = Encode::encode(utf8 => $data);
-ok !Encode::is_utf8($bytes), "converted UTF-8 to bytes";
-$q->param(data => $bytes);
-is $q->param('data'), $data;
-ok Encode::is_utf8($q->param('data')), 'param() decoded UTF-8';
+++ /dev/null
-# test CGI::Util::escape
-use Test::More tests => 4;
-use_ok("CGI::Util");
-
-# Byte strings should be escaped byte by byte:
-# 1) not a valid utf-8 sequence:
-my $uri = "pe\x{f8}\x{ed}\x{e8}ko.ogg";
-is(CGI::Util::escape($uri), "pe%F8%ED%E8ko.ogg", "Escape a Latin-2 string");
-
-# 2) is a valid utf-8 sequence, but not an UTF-8-flagged string
-# This happens often: people write utf-8 strings to source, but forget
-# to tell perl about it by "use utf8;"--this is obviously wrong, but we
-# have to handle it gracefully, for compatibility with CGI.pm under
-# perl-5.8.x
-#
-$uri = "pe\x{c5}\x{99}\x{c3}\x{ad}\x{c4}\x{8d}ko.ogg";
-is(CGI::Util::escape($uri), "pe%C5%99%C3%AD%C4%8Dko.ogg",
- "Escape an utf-8 byte string");
-
-SKIP:
-{
- # This tests CGI::Util::escape() when fed with UTF-8-flagged string
- # -- dankogai
- skip("Unicode strings not available in $]", 1) if ($] < 5.008);
- $uri = "\x{5c0f}\x{98fc} \x{5f3e}.txt"; # KOGAI, Dan, in Kanji
- is(CGI::Util::escape($uri), "%E5%B0%8F%E9%A3%BC%20%E5%BC%BE.txt",
- "Escape string with UTF-8 flag");
-}
-__END__
+++ /dev/null
-#!/usr/local/bin/perl -w
-
-# Test ability to escape() and unescape() punctuation characters
-# except for qw(- . _).
-
-$| = 1;
-
-use Test::More tests => 57;
-use Config;
-use_ok ( 'CGI::Util', qw(escape unescape) );
-
-# ASCII order, ASCII codepoints, ASCII repertoire
-
-my %punct = (
- ' ' => '20', '!' => '21', '"' => '22', '#' => '23',
- '$' => '24', '%' => '25', '&' => '26', '\'' => '27',
- '(' => '28', ')' => '29', '*' => '2A', '+' => '2B',
- ',' => '2C', '/' => '2F', # '-' => '2D', '.' => '2E'
- ':' => '3A', ';' => '3B', '<' => '3C', '=' => '3D',
- '>' => '3E', '?' => '3F', '[' => '5B', '\\' => '5C',
- ']' => '5D', '^' => '5E', '`' => '60', # '_' => '5F',
- '{' => '7B', '|' => '7C', '}' => '7D', # '~' => '7E',
- );
-
-# The sort order may not be ASCII on EBCDIC machines:
-
-my $i = 1;
-
-foreach(sort(keys(%punct))) {
- $i++;
- my $escape = "AbC\%$punct{$_}dEF";
- my $cgi_escape = escape("AbC$_" . "dEF");
- is($escape, $cgi_escape , "# $escape ne $cgi_escape");
- $i++;
- my $unescape = "AbC$_" . "dEF";
- my $cgi_unescape = unescape("AbC\%$punct{$_}dEF");
- is($unescape, $cgi_unescape , "# $unescape ne $cgi_unescape");
-}
-
use vars qw(
$VERSION
);
-$VERSION = "5.5002";
+$VERSION = "5.5001";
package CPAN::Author;
use strict;
use vars qw(
$VERSION
);
-$VERSION = "5.5002";
+$VERSION = "5.5001";
package CPAN::CacheMgr;
use strict;
use vars qw(
$VERSION
);
-$VERSION = "5.5006";
+$VERSION = "5.5005";
#-> sub CPAN::FTP::ftp_statistics
# if they want to rewrite, they need to pass in a filehandle
use CPAN::HTTP::Credentials;
use HTTP::Tiny 0.005;
-$CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9601";
+$CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9600";
# CPAN::HTTP::Client is adapted from parts of cpanm by Tatsuhiko Miyagawa
# and parts of LWP by Gisle Aas
=cut
-$VERSION = "5.5005"; # see also CPAN::Config::VERSION at end of file
+$VERSION = "5.5003"; # see also CPAN::Config::VERSION at end of file
%can = (
commit => "Commit changes to disk",
use strict;
use vars qw($AUTOLOAD $VERSION);
- $VERSION = "5.5005";
+ $VERSION = "5.5002";
# 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 = "1.9600";
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
use CPAN::HTTP::Credentials;
# we delay requiring LWP::UserAgent and setting up inheritance until we need it
-$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.9601";
+$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.9600";
sub config {
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
-$VERSION = "1.9601";
+$VERSION = "1.9600";
use Carp;
use FileHandle;
use Config;
use Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
-$VERSION = "0.22";
+$VERSION = "0.20";
@ISA = ("Exporter");
@EXPORT_OK = qw( plv2hash summary myconfig signature );
%EXPORT_TAGS = (
my %BTD = map { $_ => 0 } qw(
DEBUGGING
- NO_HASH_SEED
NO_MATHOMS
+ NO_HASH_SEED
NO_TAINT_SUPPORT
PERL_BOOL_AS_CHAR
PERL_DISABLE_PMC
PERL_DONT_CREATE_GVSV
PERL_EXTERNAL_GLOB
+ PERL_HASH_FUNC_SIPHASH
+ PERL_HASH_FUNC_SDBM
PERL_HASH_FUNC_DJB2
+ PERL_HASH_FUNC_SUPERFAST
PERL_HASH_FUNC_MURMUR3
PERL_HASH_FUNC_ONE_AT_A_TIME
PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
- PERL_HASH_FUNC_SDBM
- PERL_HASH_FUNC_SIPHASH
- PERL_HASH_FUNC_SUPERFAST
PERL_IS_MINIPERL
PERL_MALLOC_WRAP
PERL_MEM_LOG
HAVE_INTERP_INTERN
MULTIPLICITY
MYMALLOC
+ PERLIO_LAYERS
PERL_DEBUG_READONLY_COW
PERL_DEBUG_READONLY_OPS
PERL_GLOBAL_STRUCT
- PERL_GLOBAL_STRUCT_PRIVATE
PERL_IMPLICIT_CONTEXT
PERL_IMPLICIT_SYS
- PERLIO_LAYERS
PERL_MAD
PERL_MICRO
PERL_NEED_APPCTX
USE_LARGE_FILES
USE_LOCALE_COLLATE
USE_LOCALE_NUMERIC
- USE_LOCALE_TIME
USE_LONG_DOUBLE
USE_PERLIO
USE_REENTRANT_API
sub plv2hash
{
my %config;
+ for (split m/\n+/ => join "\n", @_) {
+
+ if (s/^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)//) {
+ $config{"package"} = $1;
+ my $rev = $2;
+ $rev =~ s/^ revision \s+ (\S+) \s*//x and $config{revision} = $1;
+ $rev and $config{version_patchlevel_string} = $rev;
+ my ($rel) = $config{package} =~ m{perl(\d)};
+ my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)};
+ defined $vers && defined $subvers && defined $rel and
+ $config{version} = "$rel.$vers.$subvers";
+ next;
+ }
- my $pv = join "\n" => @_;
-
- if ($pv =~ m/^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)/m) {
- $config{"package"} = $1;
- my $rev = $2;
- $rev =~ s/^ revision \s+ (\S+) \s*//x and $config{revision} = $1;
- $rev and $config{version_patchlevel_string} = $rev;
- my ($rel) = $config{"package"} =~ m{perl(\d)};
- my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)};
- defined $vers && defined $subvers && defined $rel and
- $config{version} = "$rel.$vers.$subvers";
- }
-
- if ($pv =~ m/^\s+(Snapshot of:)\s+(\S+)/) {
- $config{git_commit_id_title} = $1;
- $config{git_commit_id} = $2;
- }
+ if (s/^\s+(Snapshot of:)\s+(\S+)//) {
+ $config{git_commit_id_title} = $1;
+ $config{git_commit_id} = $2;
+ next;
+ }
- if (my %kv = ($pv =~ m{\b
- (\w+) # key
- \s*= # assign
- ( '\s*[^']*?\s*' # quoted value
- | \S+[^=]*?\s*\n # unquoted running till end of line
- | \S+ # unquoted value
- | \s*\n # empty
- )
- (?:,?\s+|\s*\n)? # separator (5.8.x reports did not have a ','
- }gx)) { # between every kv pair
+ my %kv = m/\G,?\s*([^=]+)=('[^']+?'|\S+)/gc;
while (my ($k, $v) = each %kv) {
$k =~ s/\s+$//;
- $v =~ s/\s*\n\z//;
$v =~ s/,$//;
$v =~ m/^'(.*)'$/ and $v = $1;
+ $v =~ s/^\s+//;
$v =~ s/\s+$//;
$config{$k} = $v;
}
}
-
my $build = { %empty_build };
-
- $pv =~ m{^\s+Compiled at\s+(.*)}m
- and $build->{stamp} = $1;
- $pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*?)(?:[\s\n]+Buil[td] under)}ms
- and $build->{patches} = [ split m/\n+\s*/, $1 ];
- $pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*?)(?:[\s\n]+(?:Locally applied|Buil[td] under))}ms
- and map { $build->{options}{$_} = 1 } split m/\s+|\n/ => $1;
-
$build->{osname} = $config{osname};
- $pv =~ m{^\s+Built under\s+(.*)}m
- and $build->{osname} = $1;
- $config{osname} ||= $build->{osname};
-
return _make_derived ({
build => $build,
environment => {},
}
else {
#y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
- my $cnf = plv2hash (qx[$^X -V]);
-
- $build->{$_} = $cnf->{build}{$_} for qw( osname stamp patches options );
+ my $pv = qx[$^X -V];
+ $pv =~ s{.*?\n\n}{}s;
+ $pv =~ s{\n(?: \s+|\t\s*)}{\0}g;
+
+ # print STDERR $pv;
+
+ $pv =~ m{^\s+Built under\s+(.*)}m
+ and $build->{osname} = $1;
+ $pv =~ m{^\s+Compiled at\s+(.*)}m
+ and $build->{stamp} = $1;
+ $pv =~ m{^\s+Locally applied patches:(?:\s+|\0)(.*)}m
+ and $build->{patches} = [ split m/\0+/, $1 ];
+ $pv =~ m{^\s+Compile-time options:(?:\s+|\0)(.*)}m
+ and map { $build->{options}{$_} = 1 } split m/\s+|\0/ => $1;
}
my @KEYS = keys %ENV;
--- /dev/null
+#!/usr/bin/perl
+
+use Test::More;
+
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok ();
--- /dev/null
+#!/usr/bin/perl
+
+use Test::More;
+
+eval "use Test::Pod::Coverage tests => 1";
+plan skip_all => "Test::Pod::Coverage required for testing POD Coverage" if $@;
+pod_coverage_ok ("Config::Perl::V", "Config::Perl::V is covered");
}
ok (my $conf = Config::Perl::V::myconfig, "Read config");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
+for (qw( build environment config inc )) {
+ ok (exists $conf->{build}, "Has build entry");
+ }
is (lc $conf->{build}{osname}, lc $conf->{config}{osname}, "osname");
SKIP: {
BEGIN {
use Test::More;
- my $tests = 91;
+ my $tests = 8;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
is ($conf->{build}{stamp}, 0, "No build time known");
is ($conf->{config}{version}, "5.10.0", "reconstructed \%Config{version}");
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
__END__
Summary of my perl5 (revision 5 version 10 subversion 0) configuration:
Platform:
+++ /dev/null
-#!/pro/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN {
- use Test::More;
- my $tests = 92;
- unless ($ENV{PERL_CORE}) {
- require Test::NoWarnings;
- Test::NoWarnings->import ();
- $tests++;
- }
-
- plan tests => $tests;
- }
-
-use Config::Perl::V;
-
-ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
-
-is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "Mar 23 2010 17:34:56", "Build time");
-is ($conf->{config}{"package"}, "perl5", "reconstructed \%Config{package}");
-is ($conf->{config}{version}, "5.6.2", "reconstructed \%Config{version}");
-
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-__END__
-Summary of my perl5 (revision 5.0 version 6 subversion 2) configuration:
- Platform:
- osname=linux, osvers=2.6.31.12-0.2-default, archname=i686-linux-64int-perlio
- uname='linux nb09 2.6.31.12-0.2-default #1 smp 2010-03-16 21:25:39 +0100 i686 i686 i386 gnulinux '
- config_args='-Dusedevel -Duse64bitint -Duseperlio -des -Dusedevel -Uinstallusrbinperl -Dprefix=/media/Tux/perls'
- hint=recommended, useposix=true, d_sigaction=define
- usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef
- useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
- use64bitint=define use64bitall=undef uselongdouble=undef
- Compiler:
- cc='cc', ccflags ='-DDEBUGGING -fno-strict-aliasing -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
- optimize='-O2',
- cppflags='-DDEBUGGING -fno-strict-aliasing -I/pro/local/include'
- ccversion='', gccversion='4.4.1 [gcc-4_4-branch revision 150839]', gccosandvers=''
- intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=12345678
- d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
- ivtype='long long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
- alignbytes=4, usemymalloc=n, prototype=define
- Linker and Libraries:
- ld='cc', ldflags ='-L/pro/local/lib'
- libpth=/pro/local/lib /lib /usr/lib /usr/local/lib
- libs=-lnsl -lgdbm -ldb -ldl -lm -lc -lcrypt -lutil
- perllibs=-lnsl -ldl -lm -lc -lcrypt -lutil
- libc=/lib/libc-2.10.1.so, so=so, useshrplib=false, libperl=libperl.a
- Dynamic Linking:
- dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic'
- cccdlflags='-fpic', lddlflags='-shared -L/pro/local/lib'
-
-
-Characteristics of this binary (from libperl):
- Compile-time options: DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
- Built under linux
- Compiled at Mar 23 2010 17:34:56
- @INC:
- /media/Tux/perls/lib/5.6.2/i686-linux-64int-perlio
- /media/Tux/perls/lib/5.6.2
- /media/Tux/perls/lib/site_perl/5.6.2/i686-linux-64int-perlio
- /media/Tux/perls/lib/site_perl/5.6.2
- /media/Tux/perls/lib/site_perl
- .
BEGIN {
use Test::More;
- my $tests = 111;
+ my $tests = 35;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "May 18 2013 17:34:20", "Build time");
+is ($conf->{build}{stamp}, 0, "No build time known");
is ($conf->{config}{version}, "5.18.0", "reconstructed \$Config{version}");
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- HAS_TIMES PERLIO_LAYERS PERL_DONT_CREATE_GVSV
- PERL_HASH_FUNC_ONE_AT_A_TIME_HARD PERL_MALLOC_WRAP
- PERL_PRESERVE_IVUV PERL_SAWAMPERSAND USE_64_BIT_INT
- USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
- USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LONG_DOUBLE
- USE_PERLIO USE_PERL_ATOF
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-is_deeply ($conf->{build}{patches}, [], "No local patches");
+# Some random checks
+is ($conf->{build}{options}{$_}, 0, "Runtime option $_") for qw(
+ DEBUG_LEAKING_SCALARS NO_HASH_SEED PERL_MEM_LOG_STDERR PERL_MEM_LOG_ENV
+ PERL_MEM_LOG_TIMESTAMP PERL_MICRO USE_ATTRIBUTES_FOR_PERLIO VMS_DO_SOCKETS );
my %check = (
alignbytes => 4,
+++ /dev/null
-#!/pro/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN {
- use Test::More;
- my $tests = 92;
- unless ($ENV{PERL_CORE}) {
- require Test::NoWarnings;
- Test::NoWarnings->import ();
- $tests++;
- }
-
- plan tests => $tests;
- }
-
-use Config::Perl::V;
-
-ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
-
-is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "Oct 21 2010 14:50:53", "Build time");
-is ($conf->{config}{version}, "5.8.9", "reconstructed \%Config{version}");
-is ($conf->{config}{usethreads}, "define", "This was a threaded perl");
-
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- DEBUGGING MULTIPLICITY PERL_IMPLICIT_CONTEXT
- PERL_MALLOC_WRAP THREADS_HAVE_PIDS USE_64_BIT_INT
- USE_FAST_STDIO USE_ITHREADS USE_LARGE_FILES
- USE_LONG_DOUBLE USE_PERLIO USE_REENTRANT_API
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-__END__
-Summary of my perl5 (revision 5 version 8 subversion 9) configuration:
- Platform:
- osname=linux, osvers=2.6.34.7-0.4-desktop, archname=i686-linux-thread-multi-64int-ld
- uname='linux tux09.procura.nl 2.6.34.7-0.4-desktop #1 smp preempt 2010-10-07 19:07:51 +0200 i686 i686 i386 gnulinux '
- config_args='-Dusedevel -Dusethreads -Duseithreads -Duse64bitint -Duselongdouble -Duseperlio -des -Dusedevel -Uinstallusrbinperl -Dprefix=/media/Tux/perls-t'
- hint=recommended, useposix=true, d_sigaction=define
- usethreads=define use5005threads=undef useithreads=define usemultiplicity=define
- useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
- use64bitint=define use64bitall=undef uselongdouble=define
- usemymalloc=n, bincompat5005=undef
- Compiler:
- cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBUGGING -fno-strict-aliasing -pipe -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
- optimize='-O2',
- cppflags='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBUGGING -fno-strict-aliasing -pipe -I/pro/local/include'
- ccversion='', gccversion='4.5.0 20100604 [gcc-4_5-branch revision 160292]', gccosandvers=''
- intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=12345678
- d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
- ivtype='long long', ivsize=8, nvtype='long double', nvsize=12, Off_t='off_t', lseeksize=8
- alignbytes=4, prototype=define
- Linker and Libraries:
- ld='cc', ldflags ='-L/pro/local/lib'
- libpth=/pro/local/lib /lib /usr/lib /usr/local/lib
- libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lpthread -lc
- perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
- libc=/lib/libc-2.11.2.so, so=so, useshrplib=false, libperl=libperl.a
- gnulibc_version='2.11.2'
- Dynamic Linking:
- dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
- cccdlflags='-fPIC', lddlflags='-shared -O2 -L/pro/local/lib'
-
-
-Characteristics of this binary (from libperl):
- Compile-time options: DEBUGGING MULTIPLICITY PERL_IMPLICIT_CONTEXT
- PERL_MALLOC_WRAP THREADS_HAVE_PIDS USE_64_BIT_INT
- USE_FAST_STDIO USE_ITHREADS USE_LARGE_FILES
- USE_LONG_DOUBLE USE_PERLIO USE_REENTRANT_API
- Built under linux
- Compiled at Oct 21 2010 14:50:53
- @INC:
- /media/Tux/perls-t/lib/5.8.9/i686-linux-thread-multi-64int-ld
- /media/Tux/perls-t/lib/5.8.9
- /media/Tux/perls-t/lib/site_perl/5.8.9/i686-linux-thread-multi-64int-ld
- /media/Tux/perls-t/lib/site_perl/5.8.9
- .
+++ /dev/null
-#!/pro/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN {
- use Test::More;
- my $tests = 93;
- unless ($ENV{PERL_CORE}) {
- require Test::NoWarnings;
- Test::NoWarnings->import ();
- $tests++;
- }
-
- plan tests => $tests;
- }
-
-use Config::Perl::V;
-
-ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
-
-is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "Dec 20 2010 12:46:00", "Build time");
-is ($conf->{config}{version}, "5.12.2", "reconstructed \%Config{version}");
-is ($conf->{config}{gccversion}, "", "not built with gcc");
-is ($conf->{config}{ccversion}, "B3910B", "built with HP C-ANSI-C");
-
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP USE_64_BIT_ALL
- USE_64_BIT_INT USE_LARGE_FILES USE_LONG_DOUBLE
- USE_PERLIO USE_PERL_ATOF
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-__END__
-Summary of my perl5 (revision 5 version 12 subversion 2) configuration:
-
- Platform:
- osname=hpux, osvers=11.31, archname=IA64.ARCHREV_0-LP64-ld
- uname='hp-ux x2 b.11.31 u ia64 2977233888 unlimited-user license '
- config_args='-Duse64bitall -Duselongdouble -des'
- hint=recommended, useposix=true, d_sigaction=define
- useithreads=undef, usemultiplicity=undef
- useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
- use64bitint=define, use64bitall=define, uselongdouble=define
- usemymalloc=n, bincompat5005=undef
- Compiler:
- cc='cc', ccflags =' -Ae -DPERL_DONT_CREATE_GVSV +Z -z -D_HPUX_SOURCE -Wl,+vnocompatwarnings +DD64 -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 ',
- optimize='+O2 +Onolimit',
- cppflags='-Aa -D__STDC_EXT__ -DPERL_DONT_CREATE_GVSV +Z -z -D_HPUX_SOURCE -Ae -DPERL_DONT_CREATE_GVSV +Z -z -D_HPUX_SOURCE -Wl,+vnocompatwarnings +DD64 -I/pro/local/include'
- ccversion='B3910B', gccversion='', gccosandvers=''
- intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=87654321
- d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
- ivtype='long', ivsize=8, nvtype='long double', nvsize=16, Off_t='off_t', lseeksize=8
- alignbytes=16, prototype=define
- Linker and Libraries:
- ld='/usr/bin/ld', ldflags ='-L/pro/local/lib +DD64 -L/usr/lib/hpux64'
- libpth=/pro/local/lib /usr/lib/hpux64 /lib /usr/lib /usr/ccs/lib /usr/local/lib
- libs=-lcl -lpthread -lnsl -lnm -ldb -ldl -ldld -lm -lsec -lc
- perllibs=-lcl -lpthread -lnsl -lnm -ldl -ldld -lm -lsec -lc
- libc=/usr/lib/hpux64/libc.so, so=so, useshrplib=false, libperl=libperl.a
- gnulibc_version=''
- Dynamic Linking:
- dlsrc=dl_hpux.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E -Wl,-B,deferred '
- cccdlflags='+Z', lddlflags='-b +vnocompatwarnings -L/pro/local/lib -L/usr/lib/hpux64'
-
-
-Characteristics of this binary (from libperl):
- Compile-time options: PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP USE_64_BIT_ALL
- USE_64_BIT_INT USE_LARGE_FILES USE_LONG_DOUBLE
- USE_PERLIO USE_PERL_ATOF
- Built under hpux
- Compiled at Dec 20 2010 12:46:00
- @INC:
- /pro/lib/perl5/site_perl/5.12.2/IA64.ARCHREV_0-LP64-ld
- /pro/lib/perl5/site_perl/5.12.2
- /pro/lib/perl5/5.12.2/IA64.ARCHREV_0-LP64-ld
- /pro/lib/perl5/5.12.2
- .
+++ /dev/null
-#!/pro/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN {
- use Test::More;
- my $tests = 93;
- unless ($ENV{PERL_CORE}) {
- require Test::NoWarnings;
- Test::NoWarnings->import ();
- $tests++;
- }
-
- plan tests => $tests;
- }
-
-use Config::Perl::V;
-
-ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
-
-is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "May 11 2012 16:36:53", "Build time");
-is ($conf->{config}{version}, "5.14.2", "reconstructed \%Config{version}");
-is ($conf->{config}{gccversion}, "", "not built with gcc");
-is ($conf->{config}{ccversion}, "11.1.0.8", "xlc version");
-
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP
- PERL_PRESERVE_IVUV PERL_USE_DEVEL USE_64_BIT_ALL
- USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO
- USE_PERL_ATOF
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-__END__
-Summary of my perl5 (revision 5 version 14 subversion 2) configuration:
-
- Platform:
- osname=aix, osvers=5.3.0.0, archname=aix-64all
- uname='aix i3 3 5 0004898ad300 '
- config_args='-Dusedevel -Duse64bitall -Uversiononly -Dinc_version_list=none -des'
- hint=recommended, useposix=true, d_sigaction=define
- useithreads=undef, usemultiplicity=undef
- useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
- use64bitint=define, use64bitall=define, uselongdouble=undef
- usemymalloc=n, bincompat5005=undef
- Compiler:
- cc='xlc -q64', ccflags ='-q64 -DDEBUGGING -qlanglvl=extended -D_ALL_SOURCE -D_ANSI_C_SOURCE -D_POSIX_SOURCE -qmaxmem=-1 -qnoansialias -DUSE_NATIVE_DLOPEN -qlanglvl=extended -I/pro/local/include -q64 -DUSE_64_BIT_ALL -q64',
- optimize='-O',
- cppflags='-DDEBUGGING -D_ALL_SOURCE -D_ANSI_C_SOURCE -D_POSIX_SOURCE -DUSE_NATIVE_DLOPEN -I/pro/local/include'
- ccversion='11.1.0.8', gccversion='', gccosandvers=''
- intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=87654321
- d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=8
- ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
- alignbytes=8, prototype=define
- Linker and Libraries:
- ld='ld', ldflags ='-L/usr/local/ppc64/lib64 -b64 -q64 -L/pro/local/lib -brtl -bdynamic -b64'
- libpth=/usr/local/ppc64/lib64 /lib /usr/lib /usr/ccs/lib /usr/local/lib /usr/lib64
- libs=-lbind -lnsl -ldbm -ldb -ldl -lld -lm -lcrypt -lc
- perllibs=-lbind -lnsl -ldl -lld -lm -lcrypt -lc
- libc=/lib/libc.a, so=a, useshrplib=false, libperl=libperl.a
- gnulibc_version=''
- Dynamic Linking:
- dlsrc=dl_aix.xs, dlext=so, d_dlsymun=undef, ccdlflags=' -bE:/pro/lib/perl5/5.14.2/aix-64all/CORE/perl.exp'
- cccdlflags=' ', lddlflags='-b64 -bhalt:4 -G -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -bnoentry -lc -lm -L/usr/local/ppc64/lib64 -L/pro/local/lib'
-
-
-Characteristics of this binary (from libperl):
- Compile-time options: DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP
- PERL_PRESERVE_IVUV PERL_USE_DEVEL USE_64_BIT_ALL
- USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO
- USE_PERL_ATOF
- Built under aix
- Compiled at May 11 2012 16:36:53
- @INC:
- /pro/lib/perl5/site_perl/5.14.2/aix-64all
- /pro/lib/perl5/site_perl/5.14.2
- /pro/lib/perl5/5.14.2/aix-64all
- /pro/lib/perl5/5.14.2
- .
+++ /dev/null
-#!/pro/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN {
- use Test::More;
- my $tests = 92;
- unless ($ENV{PERL_CORE}) {
- require Test::NoWarnings;
- Test::NoWarnings->import ();
- $tests++;
- }
-
- plan tests => $tests;
- }
-
-use Config::Perl::V;
-
-ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
-
-is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "Mar 12 2013 08:36:17", "Build time");
-is ($conf->{config}{version}, "5.16.3", "reconstructed \%Config{version}");
-is ($conf->{config}{ccversion}, "", "Using gcc. non-gcc version should not be defined");
-
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- HAS_TIMES PERLIO_LAYERS PERL_DONT_CREATE_GVSV
- PERL_MALLOC_WRAP PERL_PRESERVE_IVUV USE_64_BIT_INT
- USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
- USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_PERLIO
- USE_PERL_ATOF
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-__END__
-Summary of my perl5 (revision 5 version 16 subversion 3) configuration:
-
- Platform:
- osname=linux, osvers=3.4.33-2.24-desktop, archname=i686-linux-64int
- uname='linux lx09 3.4.33-2.24-desktop #1 smp preempt tue feb 26 03:34:33 utc 2013 (5f00a32) i686 i686 i386 gnulinux '
- config_args='-Duse64bitint -Duselongdouble -des'
- hint=previous, useposix=true, d_sigaction=define
- useithreads=undef, usemultiplicity=undef
- useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
- use64bitint=define, use64bitall=undef, uselongdouble=undef
- usemymalloc=n, bincompat5005=undef
- Compiler:
- cc='cc', ccflags ='-fno-strict-aliasing -pipe -fstack-protector -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
- optimize='-O2',
- cppflags='-fno-strict-aliasing -pipe -fstack-protector -I/pro/local/include -fno-strict-aliasing -pipe -fstack-protector -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
- ccversion='', gccversion='4.7.1 20120723 [gcc-4_7-branch revision 189773]', gccosandvers=''
- intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=12345678
- d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
- ivtype='long long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
- alignbytes=4, prototype=define
- Linker and Libraries:
- ld='cc', ldflags ='-L/pro/local/lib -fstack-protector'
- libpth=/pro/local/lib /lib /usr/lib /usr/local/lib
- libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat
- perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
- libc=/lib/libc-2.15.so, so=so, useshrplib=false, libperl=libperl.a
- gnulibc_version='2.15'
- Dynamic Linking:
- dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
- cccdlflags='-fPIC', lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector'
-
-
-Characteristics of this binary (from libperl):
- Compile-time options: HAS_TIMES PERLIO_LAYERS PERL_DONT_CREATE_GVSV
- PERL_MALLOC_WRAP PERL_PRESERVE_IVUV USE_64_BIT_INT
- USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
- USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_PERLIO
- USE_PERL_ATOF
- Built under linux
- Compiled at Mar 12 2013 08:36:17
- @INC:
- /pro/lib/perl5/site_perl/5.16.3/i686-linux-64int
- /pro/lib/perl5/site_perl/5.16.3
- /pro/lib/perl5/5.16.3/i686-linux-64int
- /pro/lib/perl5/5.16.3
- .
+++ /dev/null
-#!/pro/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN {
- use Test::More;
- my $tests = 150;
- unless ($ENV{PERL_CORE}) {
- require Test::NoWarnings;
- Test::NoWarnings->import ();
- $tests++;
- }
-
- plan tests => $tests;
- }
-
-use Config::Perl::V;
-
-ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
-
-is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "Aug 25 2013 01:24:40", "Build time");
-is ($conf->{config}{version}, "5.16.2", "reconstructed \%Config{version}");
-is ($conf->{config}{ccversion}, "", "Using gcc. non-gcc version should not be defined");
-
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- HAS_TIMES MULTIPLICITY PERLIO_LAYERS
- PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
- PERL_MALLOC_WRAP PERL_PRESERVE_IVUV USE_64_BIT_ALL
- USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES
- USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE
- USE_LOCALE_NUMERIC USE_PERLIO USE_PERL_ATOF
- USE_REENTRANT_API
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-is_deeply ($conf->{build}{patches}, [
- "/Library/Perl/Updates/<version> comes before system perl directories",
- "installprivlib and installarchlib points to the Updates directory",
- "CVE-2013-1667 hashtable DOS fix",
- ], "Local patches");
-
-my %check = (
-
- archname => "darwin-thread-multi-2level",
- bincompat5005 => "undef",
- config_args => "-ds -e -Dprefix=/usr -Dccflags=-g -pipe -Dldflags= -Dman3ext=3pm -Duseithreads -Duseshrplib -Dinc_version_list=none -Dcc=cc",
- d_sfio => "undef",
- d_sigaction => "define",
- hint => "recommended",
- myuname => "darwin jackson.apple.com 13.0 darwin kernel version 13.0.0: tue jul 30 20:52:22 pdt 2013; root:xnu-2422.1.53~3release_x86_64 x86_64",
- use64bitall => "define",
- use64bitint => "define",
- useithreads => "define",
- uselargefiles => "define",
- uselongdouble => "undef",
- usemultiplicity => "define",
- usemymalloc => "n",
- useperlio => "define",
- useposix => "true",
- usesocks => "undef",
-
- alignbytes => 8,
- byteorder => "12345678",
- cc => "cc",
- ccflags => "-arch x86_64 -arch i386 -g -pipe -fno-common -DPERL_DARWIN -fno-strict-aliasing -fstack-protector -I/usr/local/include",
- ccversion => "",
- cppflags => "-g -pipe -fno-common -DPERL_DARWIN -fno-strict-aliasing -fstack-protector -I/usr/local/include",
- d_longdbl => "define",
- d_longlong => "define",
- doublesize => 8,
- gccosandvers => "",
- gccversion => "4.2.1 Compatible Apple LLVM 5.0 (clang-500.0.68)",
- intsize => 4,
- ivsize => 8,
- ivtype => "long",
- longdblsize => 16,
- longlongsize => 8,
- longsize => 8,
- lseeksize => 8,
- nvsize => 8,
- nvtype => "double",
- lseektype => "off_t",
- optimize => "-Os",
- prototype => "define",
- ptrsize => 8,
-
- gnulibc_version => "",
- ld => "cc -mmacosx-version-min=10.9",
- ldflags => "-arch x86_64 -arch i386 -fstack-protector -L/usr/local/lib",
- libc => "",
- libperl => "libperl.dylib",
- libpth => "/usr/local/lib /usr/lib",
- libs => "",
- perllibs => "",
- so => "dylib",
- useshrplib => "true",
-
- cccdlflags => "",
- ccdlflags => "",
- d_dlsymun => "undef",
- dlext => "bundle",
- dlsrc => "dl_dlopen.xs",
- lddlflags => "-arch x86_64 -arch i386 -bundle -undefined dynamic_lookup -L/usr/local/lib -fstack-protector",
- );
-is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check;
-
-
-__END__
-Summary of my perl5 (revision 5 version 16 subversion 2) configuration:
-
- Platform:
- osname=darwin, osvers=13.0, archname=darwin-thread-multi-2level
- uname='darwin jackson.apple.com 13.0 darwin kernel version 13.0.0: tue jul 30 20:52:22 pdt 2013; root:xnu-2422.1.53~3release_x86_64 x86_64 '
- config_args='-ds -e -Dprefix=/usr -Dccflags=-g -pipe -Dldflags= -Dman3ext=3pm -Duseithreads -Duseshrplib -Dinc_version_list=none -Dcc=cc'
- hint=recommended, useposix=true, d_sigaction=define
- useithreads=define, usemultiplicity=define
- useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
- use64bitint=define, use64bitall=define, uselongdouble=undef
- usemymalloc=n, bincompat5005=undef
- Compiler:
- cc='cc', ccflags ='-arch x86_64 -arch i386 -g -pipe -fno-common -DPERL_DARWIN -fno-strict-aliasing -fstack-protector -I/usr/local/include',
- optimize='-Os',
- cppflags='-g -pipe -fno-common -DPERL_DARWIN -fno-strict-aliasing -fstack-protector -I/usr/local/include'
- ccversion='', gccversion='4.2.1 Compatible Apple LLVM 5.0 (clang-500.0.68)', gccosandvers=''
- intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678
- d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
- ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
- alignbytes=8, prototype=define
- Linker and Libraries:
- ld='cc -mmacosx-version-min=10.9', ldflags ='-arch x86_64 -arch i386 -fstack-protector -L/usr/local/lib'
- libpth=/usr/local/lib /usr/lib
- libs=
- perllibs=
- libc=, so=dylib, useshrplib=true, libperl=libperl.dylib
- gnulibc_version=''
- Dynamic Linking:
- dlsrc=dl_dlopen.xs, dlext=bundle, d_dlsymun=undef, ccdlflags=' '
- cccdlflags=' ', lddlflags='-arch x86_64 -arch i386 -bundle -undefined dynamic_lookup -L/usr/local/lib -fstack-protector'
-
-
-Characteristics of this binary (from libperl):
- Compile-time options: HAS_TIMES MULTIPLICITY PERLIO_LAYERS
- PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
- PERL_MALLOC_WRAP PERL_PRESERVE_IVUV USE_64_BIT_ALL
- USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES
- USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE
- USE_LOCALE_NUMERIC USE_PERLIO USE_PERL_ATOF
- USE_REENTRANT_API
- Locally applied patches:
- /Library/Perl/Updates/<version> comes before system perl directories
- installprivlib and installarchlib points to the Updates directory
- CVE-2013-1667 hashtable DOS fix
- Built under darwin
- Compiled at Aug 25 2013 01:24:40
- %ENV:
- PERL5LIB=""
- PERL5OPT=""
- PERL5_CPANPLUS_IS_RUNNING="37393"
- PERL5_CPAN_IS_RUNNING="37393"
- @INC:
- /Library/Perl/5.16/darwin-thread-multi-2level
- /Library/Perl/5.16
- /Network/Library/Perl/5.16/darwin-thread-multi-2level
- /Network/Library/Perl/5.16
- /Library/Perl/Updates/5.16.2/darwin-thread-multi-2level
- /Library/Perl/Updates/5.16.2
- /System/Library/Perl/5.16/darwin-thread-multi-2level
- /System/Library/Perl/5.16
- /System/Library/Perl/Extras/5.16/darwin-thread-multi-2level
- /System/Library/Perl/Extras/5.16
- .
-
+++ /dev/null
-#!/pro/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN {
- use Test::More;
- my $tests = 111;
- unless ($ENV{PERL_CORE}) {
- require Test::NoWarnings;
- Test::NoWarnings->import ();
- $tests++;
- }
-
- plan tests => $tests;
- }
-
-use Config::Perl::V;
-
-ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
-
-is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "Jan 9 2014 09:22:04", "Build time");
-is ($conf->{config}{version}, "5.18.2", "reconstructed \$Config{version}");
-
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- HAS_TIMES PERLIO_LAYERS PERL_DONT_CREATE_GVSV
- PERL_HASH_FUNC_ONE_AT_A_TIME_HARD PERL_MALLOC_WRAP
- PERL_PRESERVE_IVUV PERL_SAWAMPERSAND USE_64_BIT_INT
- USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
- USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LONG_DOUBLE
- USE_PERLIO USE_PERL_ATOF
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-is_deeply ($conf->{build}{patches}, [], "No local patches");
-
-my %check = (
- alignbytes => 4,
- api_version => 18,
- bincompat5005 => "undef",
- byteorder => 12345678,
- cc => "cc",
- cccdlflags => "-fPIC",
- ccdlflags => "-Wl,-E",
- config_args => "-Duse64bitint -Duselongdouble -des",
- gccversion => "4.8.1 20130909 [gcc-4_8-branch revision 202388]",
- gnulibc_version => "2.18",
- ivsize => 8,
- ivtype => "long long",
- ld => "cc",
- lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector",
- ldflags => "-L/pro/local/lib -fstack-protector",
- libc => "/lib/libc-2.18.so",
- lseektype => "off_t",
- osvers => "3.11.6-4-desktop",
- use64bitint => "define",
- );
-is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check;
-
-__END__
-Summary of my perl5 (revision 5 version 18 subversion 2) configuration:
-
- Platform:
- osname=linux, osvers=3.11.6-4-desktop, archname=i686-linux-64int-ld
- uname='linux lx09 3.11.6-4-desktop #1 smp preempt wed oct 30 18:04:56 utc 2013 (e6d4a27) i686 i686 i386 gnulinux '
- config_args='-Duse64bitint -Duselongdouble -des'
- hint=recommended, useposix=true, d_sigaction=define
- useithreads=undef, usemultiplicity=undef
- useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
- use64bitint=define, use64bitall=undef, uselongdouble=define
- usemymalloc=n, bincompat5005=undef
- Compiler:
- cc='cc', ccflags ='-fno-strict-aliasing -pipe -fstack-protector -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
- optimize='-O2',
- cppflags='-fno-strict-aliasing -pipe -fstack-protector -I/pro/local/include'
- ccversion='', gccversion='4.8.1 20130909 [gcc-4_8-branch revision 202388]', gccosandvers=''
- intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=12345678
- d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
- ivtype='long long', ivsize=8, nvtype='long double', nvsize=12, Off_t='off_t', lseeksize=8
- alignbytes=4, prototype=define
- Linker and Libraries:
- ld='cc', ldflags ='-L/pro/local/lib -fstack-protector'
- libpth=/pro/local/lib /lib /usr/lib /usr/local/lib
- libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat
- perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
- libc=/lib/libc-2.18.so, so=so, useshrplib=false, libperl=libperl.a
- gnulibc_version='2.18'
- Dynamic Linking:
- dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
- cccdlflags='-fPIC', lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector'
-
-
-Characteristics of this binary (from libperl):
- Compile-time options: HAS_TIMES PERLIO_LAYERS PERL_DONT_CREATE_GVSV
- PERL_HASH_FUNC_ONE_AT_A_TIME_HARD PERL_MALLOC_WRAP
- PERL_PRESERVE_IVUV PERL_SAWAMPERSAND USE_64_BIT_INT
- USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
- USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LONG_DOUBLE
- USE_PERLIO USE_PERL_ATOF
- Built under linux
- Compiled at Jan 9 2014 09:22:04
- @INC:
- /pro/lib/perl5/site_perl/5.18.2/i686-linux-64int-ld
- /pro/lib/perl5/site_perl/5.18.2
- /pro/lib/perl5/5.18.2/i686-linux-64int-ld
- /pro/lib/perl5/5.18.2
- .
+++ /dev/null
-#!/pro/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN {
- use Test::More;
- my $tests = 111;
- unless ($ENV{PERL_CORE}) {
- require Test::NoWarnings;
- Test::NoWarnings->import ();
- $tests++;
- }
-
- plan tests => $tests;
- }
-
-use Config::Perl::V;
-
-ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
-ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
-
-is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
-is ($conf->{build}{stamp}, "Jun 30 2014 15:37:09", "Build time");
-is ($conf->{config}{version}, "5.20.0", "reconstructed \$Config{version}");
-
-my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
-foreach my $o (sort qw(
- HAS_TIMES MULTIPLICITY PERLIO_LAYERS
- PERL_DONT_CREATE_GVSV
- PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
- PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP
- PERL_NEW_COPY_ON_WRITE PERL_PRESERVE_IVUV
- PERL_USE_DEVEL USE_64_BIT_INT USE_ITHREADS
- USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
- USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LONG_DOUBLE
- USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API
- )) {
- is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
- delete $opt->{$o};
- }
-foreach my $o (sort keys %$opt) {
- is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
- }
-
-is_deeply ($conf->{build}{patches}, [], "No local patches");
-
-my %check = (
- alignbytes => 4,
- api_version => 20,
- bincompat5005 => "undef",
- byteorder => 12345678,
- cc => "cc",
- cccdlflags => "-fPIC",
- ccdlflags => "-Wl,-E",
- config_args => "-Dusedevel -Uversiononly -Dinc_version_list=none -Duse64bitint -Dusethreads -Duseithreads -Duselongdouble -des",
- gccversion => "4.8.1 20130909 [gcc-4_8-branch revision 202388]",
- gnulibc_version => "2.18",
- ivsize => 8,
- ivtype => "long long",
- ld => "cc",
- lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector",
- ldflags => "-L/pro/local/lib -fstack-protector",
- libc => "libc-2.18.so",
- lseektype => "off_t",
- osvers => "3.11.10-17-desktop",
- use64bitint => "define",
- );
-is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check;
-
-__END__
-Summary of my perl5 (revision 5 version 20 subversion 0) configuration:
-
- Platform:
- osname=linux, osvers=3.11.10-17-desktop, archname=i686-linux-thread-multi-64int-ld
- uname='linux lx09 3.11.10-17-desktop #1 smp preempt mon jun 16 15:28:13 utc 2014 (fba7c1f) i686 i686 i386 gnulinux '
- config_args='-Dusedevel -Uversiononly -Dinc_version_list=none -Duse64bitint -Dusethreads -Duseithreads -Duselongdouble -des'
- hint=recommended, useposix=true, d_sigaction=define
- useithreads=define, usemultiplicity=define
- use64bitint=define, use64bitall=undef, uselongdouble=define
- usemymalloc=n, bincompat5005=undef
- Compiler:
- cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -fwrapv -fno-strict-aliasing -pipe -fstack-protector -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
- optimize='-O2',
- cppflags='-D_REENTRANT -D_GNU_SOURCE -fwrapv -fno-strict-aliasing -pipe -fstack-protector -I/pro/local/include'
- ccversion='', gccversion='4.8.1 20130909 [gcc-4_8-branch revision 202388]', gccosandvers=''
- intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=12345678
- d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
- ivtype='long long', ivsize=8, nvtype='long double', nvsize=12, Off_t='off_t', lseeksize=8
- alignbytes=4, prototype=define
- Linker and Libraries:
- ld='cc', ldflags ='-L/pro/local/lib -fstack-protector'
- libpth=/usr/local/lib /usr/lib/gcc/i586-suse-linux/4.8/include-fixed /usr/lib/gcc/i586-suse-linux/4.8/../../../../i586-suse-linux/lib /usr/lib /pro/local/lib /lib
- libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lpthread -lc -lgdbm_compat
- perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
- libc=libc-2.18.so, so=so, useshrplib=false, libperl=libperl.a
- gnulibc_version='2.18'
- Dynamic Linking:
- dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
- cccdlflags='-fPIC', lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector'
-
-
-Characteristics of this binary (from libperl):
- Compile-time options: HAS_TIMES MULTIPLICITY PERLIO_LAYERS
- PERL_DONT_CREATE_GVSV
- PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
- PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP
- PERL_NEW_COPY_ON_WRITE PERL_PRESERVE_IVUV
- PERL_USE_DEVEL USE_64_BIT_INT USE_ITHREADS
- USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
- USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LONG_DOUBLE
- USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API
- Built under linux
- Compiled at Jun 30 2014 15:37:09
- @INC:
- /pro/lib/perl5/site_perl/5.20.0/i686-linux-thread-multi-64int-ld
- /pro/lib/perl5/site_perl/5.20.0
- /pro/lib/perl5/5.20.0/i686-linux-thread-multi-64int-ld
- /pro/lib/perl5/5.20.0
- .
+++ /dev/null
-^t/par.t
-^t/signature.t
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use Module::Build 0.25;
-use Getopt::Long;
-
-my %opt_defs = (
- module => {type => '=s',
- desc => 'The name of the module to configure (required)'},
- feature => {type => ':s',
- desc => 'Print the value of a feature or all features'},
- config => {type => ':s',
- desc => 'Print the value of a config option'},
- set_feature => {type => '=s%',
- desc => "Set a feature to 'true' or 'false'"},
- set_config => {type => '=s%',
- desc => 'Set a config option to the given value'},
- eval => {type => '',
- desc => 'eval() config values before setting'},
- help => {type => '',
- desc => 'Print a help message and exit'},
- );
-
-my %opts;
-GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs);
-print usage(%opt_defs) and exit(0)
- if $opts{help};
-
-my @exclusive = qw(feature config set_feature set_config);
-die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs)
- unless grep(exists $opts{$_}, @exclusive) == 1;
-
-die "Option --module is required\n" . usage(%opt_defs)
- unless $opts{module};
-
-my $cf = load_config($opts{module});
-
-if (exists $opts{feature}) {
-
- if (length $opts{feature}) {
- print $cf->feature($opts{feature});
- } else {
- my %auto;
- # note: need to support older ConfigData.pm's
- @auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names");
-
- print " Features defined in $cf:\n";
- foreach my $name (sort $cf->feature_names) {
- print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n";
- }
- }
-
-} elsif (exists $opts{config}) {
-
- require Data::Dumper;
- local $Data::Dumper::Terse = 1;
-
- if (length $opts{config}) {
- print Data::Dumper::Dumper($cf->config($opts{config})), "\n";
- } else {
- print " Configuration defined in $cf:\n";
- foreach my $name (sort $cf->config_names) {
- print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n";
- }
- }
-
-} elsif (exists $opts{set_feature}) {
- my %to_set = %{$opts{set_feature}};
- while (my ($k, $v) = each %to_set) {
- die "Feature value must be 0 or 1\n" unless $v =~ /^[01]$/;
- $cf->set_feature($k, 0+$v); # Cast to a number, not a string
- }
- $cf->write;
- print "Feature" . 's'x(keys(%to_set)>1) . " saved\n";
-
-} elsif (exists $opts{set_config}) {
-
- my %to_set = %{$opts{set_config}};
- while (my ($k, $v) = each %to_set) {
- if ($opts{eval}) {
- $v = eval($v);
- die $@ if $@;
- }
- $cf->set_config($k, $v);
- }
- $cf->write;
- print "Config value" . 's'x(keys(%to_set)>1) . " saved\n";
-}
-
-sub load_config {
- my $mod = shift;
-
- $mod =~ /^([\w:]+)$/
- or die "Invalid module name '$mod'";
-
- my $cf = $mod . "::ConfigData";
- eval "require $cf";
- die $@ if $@;
-
- return $cf;
-}
-
-sub usage {
- my %defs = @_;
-
- my $out = "\nUsage: $0 [options]\n\n Options include:\n";
-
- foreach my $name (sort keys %defs) {
- $out .= " --$name";
-
- for ($defs{$name}{type}) {
- /^=s$/ and $out .= " <string>";
- /^=s%$/ and $out .= " <string>=<value>";
- }
-
- pad_line($out, 35);
- $out .= "$defs{$name}{desc}\n";
- }
-
- $out .= <<EOF;
-
- Examples:
- $0 --module Foo::Bar --feature bazzable
- $0 --module Foo::Bar --config magic_number
- $0 --module Foo::Bar --set_feature bazzable=1
- $0 --module Foo::Bar --set_config magic_number=42
-
-EOF
-
- return $out;
-}
-
-sub pad_line { $_[0] .= ' ' x ($_[1] - length($_[0]) + rindex($_[0], "\n")) }
-
-
-__END__
-
-=head1 NAME
-
-config_data - Query or change configuration of Perl modules
-
-=head1 SYNOPSIS
-
- # Get config/feature values
- config_data --module Foo::Bar --feature bazzable
- config_data --module Foo::Bar --config magic_number
-
- # Set config/feature values
- config_data --module Foo::Bar --set_feature bazzable=1
- config_data --module Foo::Bar --set_config magic_number=42
-
- # Print a usage message
- config_data --help
-
-=head1 DESCRIPTION
-
-The C<config_data> tool provides a command-line interface to the
-configuration of Perl modules. By "configuration", we mean something
-akin to "user preferences" or "local settings". This is a
-formalization and abstraction of the systems that people like Andreas
-Koenig (C<CPAN::Config>), Jon Swartz (C<HTML::Mason::Config>), Andy
-Wardley (C<Template::Config>), and Larry Wall (perl's own Config.pm)
-have developed independently.
-
-The configuration system employed here was developed in the context of
-C<Module::Build>. Under this system, configuration information for a
-module C<Foo>, for example, is stored in a module called
-C<Foo::ConfigData>) (I would have called it C<Foo::Config>, but that
-was taken by all those other systems mentioned in the previous
-paragraph...). These C<...::ConfigData> modules contain the
-configuration data, as well as publicly accessible methods for
-querying and setting (yes, actually re-writing) the configuration
-data. The C<config_data> script (whose docs you are currently
-reading) is merely a front-end for those methods. If you wish, you
-may create alternate front-ends.
-
-The two types of data that may be stored are called C<config> values
-and C<feature> values. A C<config> value may be any perl scalar,
-including references to complex data structures. It must, however, be
-serializable using C<Data::Dumper>. A C<feature> is a boolean (1 or
-0) value.
-
-=head1 USAGE
-
-This script functions as a basic getter/setter wrapper around the
-configuration of a single module. On the command line, specify which
-module's configuration you're interested in, and pass options to get
-or set C<config> or C<feature> values. The following options are
-supported:
-
-=over 4
-
-=item module
-
-Specifies the name of the module to configure (required).
-
-=item feature
-
-When passed the name of a C<feature>, shows its value. The value will
-be 1 if the feature is enabled, 0 if the feature is not enabled, or
-empty if the feature is unknown. When no feature name is supplied,
-the names and values of all known features will be shown.
-
-=item config
-
-When passed the name of a C<config> entry, shows its value. The value
-will be displayed using C<Data::Dumper> (or similar) as perl code.
-When no config name is supplied, the names and values of all known
-config entries will be shown.
-
-=item set_feature
-
-Sets the given C<feature> to the given boolean value. Specify the value
-as either 1 or 0.
-
-=item set_config
-
-Sets the given C<config> entry to the given value.
-
-=item eval
-
-If the C<--eval> option is used, the values in C<set_config> will be
-evaluated as perl code before being stored. This allows moderately
-complicated data structures to be stored. For really complicated
-structures, you probably shouldn't use this command-line interface,
-just use the Perl API instead.
-
-=item help
-
-Prints a help message, including a few examples, and exits.
-
-=back
-
-=head1 AUTHOR
-
-Ken Williams, kwilliams@cpan.org
-
-=head1 COPYRIGHT
-
-Copyright (c) 1999, Ken Williams. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-Module::Build(3), perl(1).
-
-=cut
+++ /dev/null
-package Module::Build;
-
-use if $] >= 5.019, 'deprecate';
-
-# This module doesn't do much of anything itself, it inherits from the
-# modules that do the real work. The only real thing it has to do is
-# figure out which OS-specific module to pull in. Many of the
-# OS-specific modules don't do anything either - most of the work is
-# done in Module::Build::Base.
-
-use strict;
-use File::Spec ();
-use File::Path ();
-use File::Basename ();
-use Perl::OSType ();
-
-use Module::Build::Base;
-
-use vars qw($VERSION @ISA);
-@ISA = qw(Module::Build::Base);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-
-# Inserts the given module into the @ISA hierarchy between
-# Module::Build and its immediate parent
-sub _interpose_module {
- my ($self, $mod) = @_;
- eval "use $mod";
- die $@ if $@;
-
- no strict 'refs';
- my $top_class = $mod;
- while (@{"${top_class}::ISA"}) {
- last if ${"${top_class}::ISA"}[0] eq $ISA[0];
- $top_class = ${"${top_class}::ISA"}[0];
- }
-
- @{"${top_class}::ISA"} = @ISA;
- @ISA = ($mod);
-}
-
-if (grep {-e File::Spec->catfile($_, qw(Module Build Platform), $^O) . '.pm'} @INC) {
- __PACKAGE__->_interpose_module("Module::Build::Platform::$^O");
-
-} elsif ( my $ostype = os_type() ) {
- __PACKAGE__->_interpose_module("Module::Build::Platform::$ostype");
-
-} else {
- warn "Unknown OS type '$^O' - using default settings\n";
-}
-
-sub os_type { return Perl::OSType::os_type() }
-
-sub is_vmsish { return Perl::OSType::is_os_type('VMS') }
-sub is_windowsish { return Perl::OSType::is_os_type('Windows') }
-sub is_unixish { return Perl::OSType::is_os_type('Unix') }
-
-1;
-
-__END__
-
-=for :stopwords
-bindoc binhtml destdir distcheck distclean distdir distmeta distsign disttest
-fakeinstall html installdirs installsitebin installsitescript installvendorbin
-installvendorscript libdoc libhtml pardist ppd ppmdist realclean skipcheck
-testall testcover testdb testpod testpodcoverage versioninstall
-
-=head1 NAME
-
-Module::Build - Build and install Perl modules
-
-=head1 SYNOPSIS
-
-Standard process for building & installing modules:
-
- perl Build.PL
- ./Build
- ./Build test
- ./Build install
-
-Or, if you're on a platform (like DOS or Windows) that doesn't require
-the "./" notation, you can do this:
-
- perl Build.PL
- Build
- Build test
- Build install
-
-
-=head1 DESCRIPTION
-
-C<Module::Build> is a system for building, testing, and installing
-Perl modules. It is meant to be an alternative to
-C<ExtUtils::MakeMaker>. Developers may alter the behavior of the
-module through subclassing in a much more straightforward way than
-with C<MakeMaker>. It also does not require a C<make> on your system
-- most of the C<Module::Build> code is pure-perl and written in a very
-cross-platform way.
-
-See L<"MOTIVATIONS"> for more comparisons between C<ExtUtils::MakeMaker>
-and C<Module::Build>.
-
-To install C<Module::Build>, and any other module that uses
-C<Module::Build> for its installation process, do the following:
-
- perl Build.PL # 'Build.PL' script creates the 'Build' script
- ./Build # Need ./ to ensure we're using this "Build" script
- ./Build test # and not another one that happens to be in the PATH
- ./Build install
-
-This illustrates initial configuration and the running of three
-'actions'. In this case the actions run are 'build' (the default
-action), 'test', and 'install'. Other actions defined so far include:
-
- build manifest
- clean manifest_skip
- code manpages
- config_data pardist
- diff ppd
- dist ppmdist
- distcheck prereq_data
- distclean prereq_report
- distdir pure_install
- distinstall realclean
- distmeta retest
- distsign skipcheck
- disttest test
- docs testall
- fakeinstall testcover
- help testdb
- html testpod
- install testpodcoverage
- installdeps versioninstall
-
-You can run the 'help' action for a complete list of actions.
-
-
-=head1 GUIDE TO DOCUMENTATION
-
-The documentation for C<Module::Build> is broken up into sections:
-
-=over
-
-=item General Usage (L<Module::Build>)
-
-This is the document you are currently reading. It describes basic
-usage and background information. Its main purpose is to assist the
-user who wants to learn how to invoke and control C<Module::Build>
-scripts at the command line.
-
-=item Authoring Reference (L<Module::Build::Authoring>)
-
-This document describes the structure and organization of
-C<Module::Build>, and the relevant concepts needed by authors who are
-writing F<Build.PL> scripts for a distribution or controlling
-C<Module::Build> processes programmatically.
-
-=item API Reference (L<Module::Build::API>)
-
-This is a reference to the C<Module::Build> API.
-
-=item Cookbook (L<Module::Build::Cookbook>)
-
-This document demonstrates how to accomplish many common tasks. It
-covers general command line usage and authoring of F<Build.PL>
-scripts. Includes working examples.
-
-=back
-
-
-=head1 ACTIONS
-
-There are some general principles at work here. First, each task when
-building a module is called an "action". These actions are listed
-above; they correspond to the building, testing, installing,
-packaging, etc., tasks.
-
-Second, arguments are processed in a very systematic way. Arguments
-are always key=value pairs. They may be specified at C<perl Build.PL>
-time (i.e. C<perl Build.PL destdir=/my/secret/place>), in which case
-their values last for the lifetime of the C<Build> script. They may
-also be specified when executing a particular action (i.e.
-C<Build test verbose=1>), in which case their values last only for the
-lifetime of that command. Per-action command line parameters take
-precedence over parameters specified at C<perl Build.PL> time.
-
-The build process also relies heavily on the C<Config.pm> module.
-If the user wishes to override any of the
-values in C<Config.pm>, she may specify them like so:
-
- perl Build.PL --config cc=gcc --config ld=gcc
-
-The following build actions are provided by default.
-
-=over 4
-
-=item build
-
-[version 0.01]
-
-If you run the C<Build> script without any arguments, it runs the
-C<build> action, which in turn runs the C<code> and C<docs> actions.
-
-This is analogous to the C<MakeMaker> I<make all> target.
-
-=item clean
-
-[version 0.01]
-
-This action will clean up any files that the build process may have
-created, including the C<blib/> directory (but not including the
-C<_build/> directory and the C<Build> script itself).
-
-=item code
-
-[version 0.20]
-
-This action builds your code base.
-
-By default it just creates a C<blib/> directory and copies any C<.pm>
-and C<.pod> files from your C<lib/> directory into the C<blib/>
-directory. It also compiles any C<.xs> files from C<lib/> and places
-them in C<blib/>. Of course, you need a working C compiler (probably
-the same one that built perl itself) for the compilation to work
-properly.
-
-The C<code> action also runs any C<.PL> files in your F<lib/>
-directory. Typically these create other files, named the same but
-without the C<.PL> ending. For example, a file F<lib/Foo/Bar.pm.PL>
-could create the file F<lib/Foo/Bar.pm>. The C<.PL> files are
-processed first, so any C<.pm> files (or other kinds that we deal
-with) will get copied correctly.
-
-=item config_data
-
-[version 0.26]
-
-...
-
-=item diff
-
-[version 0.14]
-
-This action will compare the files about to be installed with their
-installed counterparts. For .pm and .pod files, a diff will be shown
-(this currently requires a 'diff' program to be in your PATH). For
-other files like compiled binary files, we simply report whether they
-differ.
-
-A C<flags> parameter may be passed to the action, which will be passed
-to the 'diff' program. Consult your 'diff' documentation for the
-parameters it will accept - a good one is C<-u>:
-
- ./Build diff flags=-u
-
-=item dist
-
-[version 0.02]
-
-This action is helpful for module authors who want to package up their
-module for source distribution through a medium like CPAN. It will create a
-tarball of the files listed in F<MANIFEST> and compress the tarball using
-GZIP compression.
-
-By default, this action will use the C<Archive::Tar> module. However, you can
-force it to use binary "tar" and "gzip" executables by supplying an explicit
-C<tar> (and optional C<gzip>) parameter:
-
- ./Build dist --tar C:\path\to\tar.exe --gzip C:\path\to\zip.exe
-
-=item distcheck
-
-[version 0.05]
-
-Reports which files are in the build directory but not in the
-F<MANIFEST> file, and vice versa. (See L<manifest> for details.)
-
-=item distclean
-
-[version 0.05]
-
-Performs the 'realclean' action and then the 'distcheck' action.
-
-=item distdir
-
-[version 0.05]
-
-Creates a "distribution directory" named C<$dist_name-$dist_version>
-(if that directory already exists, it will be removed first), then
-copies all the files listed in the F<MANIFEST> file to that directory.
-This directory is what the distribution tarball is created from.
-
-=item distinstall
-
-[version 0.37]
-
-Performs the 'distdir' action, then switches into that directory and runs a
-C<perl Build.PL>, followed by the 'build' and 'install' actions in that
-directory. Use PERL_MB_OPT or F<.modulebuildrc> to set options that should be
-applied during subprocesses
-
-=item distmeta
-
-[version 0.21]
-
-Creates the F<META.yml> file that describes the distribution.
-
-F<META.yml> is a file containing various bits of I<metadata> about the
-distribution. The metadata includes the distribution name, version,
-abstract, prerequisites, license, and various other data about the
-distribution. This file is created as F<META.yml> in a simplified YAML format.
-
-F<META.yml> file must also be listed in F<MANIFEST> - if it's not, a
-warning will be issued.
-
-The current version of the F<META.yml> specification can be found
-on CPAN as L<CPAN::Meta::Spec>.
-
-=item distsign
-
-[version 0.16]
-
-Uses C<Module::Signature> to create a SIGNATURE file for your
-distribution, and adds the SIGNATURE file to the distribution's
-MANIFEST.
-
-=item disttest
-
-[version 0.05]
-
-Performs the 'distdir' action, then switches into that directory and runs a
-C<perl Build.PL>, followed by the 'build' and 'test' actions in that directory.
-Use PERL_MB_OPT or F<.modulebuildrc> to set options that should be applied
-during subprocesses
-
-
-=item docs
-
-[version 0.20]
-
-This will generate documentation (e.g. Unix man pages and HTML
-documents) for any installable items under B<blib/> that
-contain POD. If there are no C<bindoc> or C<libdoc> installation
-targets defined (as will be the case on systems that don't support
-Unix manpages) no action is taken for manpages. If there are no
-C<binhtml> or C<libhtml> installation targets defined no action is
-taken for HTML documents.
-
-=item fakeinstall
-
-[version 0.02]
-
-This is just like the C<install> action, but it won't actually do
-anything, it will just report what it I<would> have done if you had
-actually run the C<install> action.
-
-=item help
-
-[version 0.03]
-
-This action will simply print out a message that is meant to help you
-use the build process. It will show you a list of available build
-actions too.
-
-With an optional argument specifying an action name (e.g. C<Build help
-test>), the 'help' action will show you any POD documentation it can
-find for that action.
-
-=item html
-
-[version 0.26]
-
-This will generate HTML documentation for any binary or library files
-under B<blib/> that contain POD. The HTML documentation will only be
-installed if the install paths can be determined from values in
-C<Config.pm>. You can also supply or override install paths on the
-command line by specifying C<install_path> values for the C<binhtml>
-and/or C<libhtml> installation targets.
-
-With an optional C<html_links> argument set to a false value, you can
-skip the search for other documentation to link to, because that can
-waste a lot of time if there aren't any links to generate anyway:
-
- ./Build html --html_links 0
-
-=item install
-
-[version 0.01]
-
-This action will use C<ExtUtils::Install> to install the files from
-C<blib/> into the system. See L<"INSTALL PATHS">
-for details about how Module::Build determines where to install
-things, and how to influence this process.
-
-If you want the installation process to look around in C<@INC> for
-other versions of the stuff you're installing and try to delete it,
-you can use the C<uninst> parameter, which tells C<ExtUtils::Install> to
-do so:
-
- ./Build install uninst=1
-
-This can be a good idea, as it helps prevent multiple versions of a
-module from being present on your system, which can be a confusing
-situation indeed.
-
-=item installdeps
-
-[version 0.36]
-
-This action will use the C<cpan_client> parameter as a command to install
-missing prerequisites. You will be prompted whether to install
-optional dependencies.
-
-The C<cpan_client> option defaults to 'cpan' but can be set as an option or in
-F<.modulebuildrc>. It must be a shell command that takes a list of modules to
-install as arguments (e.g. 'cpanp -i' for CPANPLUS). If the program part is a
-relative path (e.g. 'cpan' or 'cpanp'), it will be located relative to the perl
-program that executed Build.PL.
-
- /opt/perl/5.8.9/bin/perl Build.PL
- ./Build installdeps --cpan_client 'cpanp -i'
- # installs to 5.8.9
-
-=item manifest
-
-[version 0.05]
-
-This is an action intended for use by module authors, not people
-installing modules. It will bring the F<MANIFEST> up to date with the
-files currently present in the distribution. You may use a
-F<MANIFEST.SKIP> file to exclude certain files or directories from
-inclusion in the F<MANIFEST>. F<MANIFEST.SKIP> should contain a bunch
-of regular expressions, one per line. If a file in the distribution
-directory matches any of the regular expressions, it won't be included
-in the F<MANIFEST>.
-
-The following is a reasonable F<MANIFEST.SKIP> starting point, you can
-add your own stuff to it:
-
- ^_build
- ^Build$
- ^blib
- ~$
- \.bak$
- ^MANIFEST\.SKIP$
- CVS
-
-See the L<distcheck> and L<skipcheck> actions if you want to find out
-what the C<manifest> action would do, without actually doing anything.
-
-=item manifest_skip
-
-[version 0.3608]
-
-This is an action intended for use by module authors, not people
-installing modules. It will generate a boilerplate MANIFEST.SKIP file
-if one does not already exist.
-
-=item manpages
-
-[version 0.28]
-
-This will generate man pages for any binary or library files under
-B<blib/> that contain POD. The man pages will only be installed if the
-install paths can be determined from values in C<Config.pm>. You can
-also supply or override install paths by specifying there values on
-the command line with the C<bindoc> and C<libdoc> installation
-targets.
-
-=item pardist
-
-[version 0.2806]
-
-Generates a PAR binary distribution for use with L<PAR> or L<PAR::Dist>.
-
-It requires that the PAR::Dist module (version 0.17 and up) is
-installed on your system.
-
-=item ppd
-
-[version 0.20]
-
-Build a PPD file for your distribution.
-
-This action takes an optional argument C<codebase> which is used in
-the generated PPD file to specify the (usually relative) URL of the
-distribution. By default, this value is the distribution name without
-any path information.
-
-Example:
-
- ./Build ppd --codebase "MSWin32-x86-multi-thread/Module-Build-0.21.tar.gz"
-
-=item ppmdist
-
-[version 0.23]
-
-Generates a PPM binary distribution and a PPD description file. This
-action also invokes the C<ppd> action, so it can accept the same
-C<codebase> argument described under that action.
-
-This uses the same mechanism as the C<dist> action to tar & zip its
-output, so you can supply C<tar> and/or C<gzip> parameters to affect
-the result.
-
-=item prereq_data
-
-[version 0.32]
-
-This action prints out a Perl data structure of all prerequisites and the versions
-required. The output can be loaded again using C<eval()>. This can be useful for
-external tools that wish to query a Build script for prerequisites.
-
-=item prereq_report
-
-[version 0.28]
-
-This action prints out a list of all prerequisites, the versions required, and
-the versions actually installed. This can be useful for reviewing the
-configuration of your system prior to a build, or when compiling data to send
-for a bug report.
-
-=item pure_install
-
-[version 0.28]
-
-This action is identical to the C<install> action. In the future,
-though, when C<install> starts writing to the file
-F<$(INSTALLARCHLIB)/perllocal.pod>, C<pure_install> won't, and that
-will be the only difference between them.
-
-=item realclean
-
-[version 0.01]
-
-This action is just like the C<clean> action, but also removes the
-C<_build> directory and the C<Build> script. If you run the
-C<realclean> action, you are essentially starting over, so you will
-have to re-create the C<Build> script again.
-
-=item retest
-
-[version 0.2806]
-
-This is just like the C<test> action, but doesn't actually build the
-distribution first, and doesn't add F<blib/> to the load path, and
-therefore will test against a I<previously> installed version of the
-distribution. This can be used to verify that a certain installed
-distribution still works, or to see whether newer versions of a
-distribution still pass the old regression tests, and so on.
-
-=item skipcheck
-
-[version 0.05]
-
-Reports which files are skipped due to the entries in the
-F<MANIFEST.SKIP> file (See L<manifest> for details)
-
-=item test
-
-[version 0.01]
-
-This will use C<Test::Harness> or C<TAP::Harness> to run any regression
-tests and report their results. Tests can be defined in the standard
-places: a file called C<test.pl> in the top-level directory, or several
-files ending with C<.t> in a C<t/> directory.
-
-If you want tests to be 'verbose', i.e. show details of test execution
-rather than just summary information, pass the argument C<verbose=1>.
-
-If you want to run tests under the perl debugger, pass the argument
-C<debugger=1>.
-
-If you want to have Module::Build find test files with different file
-name extensions, pass the C<test_file_exts> argument with an array
-of extensions, such as C<[qw( .t .s .z )]>.
-
-If you want test to be run by C<TAP::Harness>, rather than C<Test::Harness>,
-pass the argument C<tap_harness_args> as an array reference of arguments to
-pass to the TAP::Harness constructor.
-
-In addition, if a file called C<visual.pl> exists in the top-level
-directory, this file will be executed as a Perl script and its output
-will be shown to the user. This is a good place to put speed tests or
-other tests that don't use the C<Test::Harness> format for output.
-
-To override the choice of tests to run, you may pass a C<test_files>
-argument whose value is a whitespace-separated list of test scripts to
-run. This is especially useful in development, when you only want to
-run a single test to see whether you've squashed a certain bug yet:
-
- ./Build test --test_files t/something_failing.t
-
-You may also pass several C<test_files> arguments separately:
-
- ./Build test --test_files t/one.t --test_files t/two.t
-
-or use a C<glob()>-style pattern:
-
- ./Build test --test_files 't/01-*.t'
-
-=item testall
-
-[version 0.2807]
-
-[Note: the 'testall' action and the code snippets below are currently
-in alpha stage, see
-L<"http://www.nntp.perl.org/group/perl.module.build/2007/03/msg584.html"> ]
-
-Runs the C<test> action plus each of the C<test$type> actions defined by
-the keys of the C<test_types> parameter.
-
-Currently, you need to define the ACTION_test$type method yourself and
-enumerate them in the test_types parameter.
-
- my $mb = Module::Build->subclass(
- code => q(
- sub ACTION_testspecial { shift->generic_test(type => 'special'); }
- sub ACTION_testauthor { shift->generic_test(type => 'author'); }
- )
- )->new(
- ...
- test_types => {
- special => '.st',
- author => ['.at', '.pt' ],
- },
- ...
-
-=item testcover
-
-[version 0.26]
-
-Runs the C<test> action using C<Devel::Cover>, generating a
-code-coverage report showing which parts of the code were actually
-exercised during the tests.
-
-To pass options to C<Devel::Cover>, set the C<$DEVEL_COVER_OPTIONS>
-environment variable:
-
- DEVEL_COVER_OPTIONS=-ignore,Build ./Build testcover
-
-=item testdb
-
-[version 0.05]
-
-This is a synonym for the 'test' action with the C<debugger=1>
-argument.
-
-=item testpod
-
-[version 0.25]
-
-This checks all the files described in the C<docs> action and
-produces C<Test::Harness>-style output. If you are a module author,
-this is useful to run before creating a new release.
-
-=item testpodcoverage
-
-[version 0.28]
-
-This checks the pod coverage of the distribution and
-produces C<Test::Harness>-style output. If you are a module author,
-this is useful to run before creating a new release.
-
-=item versioninstall
-
-[version 0.16]
-
-** Note: since C<only.pm> is so new, and since we just recently added
-support for it here too, this feature is to be considered
-experimental. **
-
-If you have the C<only.pm> module installed on your system, you can
-use this action to install a module into the version-specific library
-trees. This means that you can have several versions of the same
-module installed and C<use> a specific one like this:
-
- use only MyModule => 0.55;
-
-To override the default installation libraries in C<only::config>,
-specify the C<versionlib> parameter when you run the C<Build.PL> script:
-
- perl Build.PL --versionlib /my/version/place/
-
-To override which version the module is installed as, specify the
-C<version> parameter when you run the C<Build.PL> script:
-
- perl Build.PL --version 0.50
-
-See the C<only.pm> documentation for more information on
-version-specific installs.
-
-=back
-
-
-=head1 OPTIONS
-
-=head2 Command Line Options
-
-The following options can be used during any invocation of C<Build.PL>
-or the Build script, during any action. For information on other
-options specific to an action, see the documentation for the
-respective action.
-
-NOTE: There is some preliminary support for options to use the more
-familiar long option style. Most options can be preceded with the
-C<--> long option prefix, and the underscores changed to dashes
-(e.g. C<--use-rcfile>). Additionally, the argument to boolean options is
-optional, and boolean options can be negated by prefixing them with
-C<no> or C<no-> (e.g. C<--noverbose> or C<--no-verbose>).
-
-=over 4
-
-=item quiet
-
-Suppress informative messages on output.
-
-=item verbose
-
-Display extra information about the Build on output. C<verbose> will
-turn off C<quiet>
-
-=item cpan_client
-
-Sets the C<cpan_client> command for use with the C<installdeps> action.
-See C<installdeps> for more details.
-
-=item use_rcfile
-
-Load the F<~/.modulebuildrc> option file. This option can be set to
-false to prevent the custom resource file from being loaded.
-
-=item allow_mb_mismatch
-
-Suppresses the check upon startup that the version of Module::Build
-we're now running under is the same version that was initially invoked
-when building the distribution (i.e. when the C<Build.PL> script was
-first run). As of 0.3601, a mismatch results in a warning instead of
-a fatal error, so this option effectively just suppresses the warning.
-
-=item debug
-
-Prints Module::Build debugging information to STDOUT, such as a trace of
-executed build actions.
-
-=back
-
-=head2 Default Options File (F<.modulebuildrc>)
-
-[version 0.28]
-
-When Module::Build starts up, it will look first for a file,
-F<$ENV{HOME}/.modulebuildrc>. If it's not found there, it will look
-in the F<.modulebuildrc> file in the directories referred to by
-the environment variables C<HOMEDRIVE> + C<HOMEDIR>, C<USERPROFILE>,
-C<APPDATA>, C<WINDIR>, C<SYS$LOGIN>. If the file exists, the options
-specified there will be used as defaults, as if they were typed on the
-command line. The defaults can be overridden by specifying new values
-on the command line.
-
-The action name must come at the beginning of the line, followed by any
-amount of whitespace and then the options. Options are given the same
-as they would be on the command line. They can be separated by any
-amount of whitespace, including newlines, as long there is whitespace at
-the beginning of each continued line. Anything following a hash mark (C<#>)
-is considered a comment, and is stripped before parsing. If more than
-one line begins with the same action name, those lines are merged into
-one set of options.
-
-Besides the regular actions, there are two special pseudo-actions: the
-key C<*> (asterisk) denotes any global options that should be applied
-to all actions, and the key 'Build_PL' specifies options to be applied
-when you invoke C<perl Build.PL>.
-
- * verbose=1 # global options
- diff flags=-u
- install --install_base /home/ken
- --install_path html=/home/ken/docs/html
- installdeps --cpan_client 'cpanp -i'
-
-If you wish to locate your resource file in a different location, you
-can set the environment variable C<MODULEBUILDRC> to the complete
-absolute path of the file containing your options.
-
-=head2 Environment variables
-
-=over
-
-=item MODULEBUILDRC
-
-[version 0.28]
-
-Specifies an alternate location for a default options file as described above.
-
-=item PERL_MB_OPT
-
-[version 0.36]
-
-Command line options that are applied to Build.PL or any Build action. The
-string is split as the shell would (e.g. whitespace) and the result is
-prepended to any actual command-line arguments.
-
-=back
-
-=head1 INSTALL PATHS
-
-[version 0.19]
-
-When you invoke Module::Build's C<build> action, it needs to figure
-out where to install things. The nutshell version of how this works
-is that default installation locations are determined from
-F<Config.pm>, and they may be overridden by using the C<install_path>
-parameter. An C<install_base> parameter lets you specify an
-alternative installation root like F</home/foo>, and a C<destdir> lets
-you specify a temporary installation directory like F</tmp/install> in
-case you want to create bundled-up installable packages.
-
-Natively, Module::Build provides default installation locations for
-the following types of installable items:
-
-=over 4
-
-=item lib
-
-Usually pure-Perl module files ending in F<.pm>.
-
-=item arch
-
-"Architecture-dependent" module files, usually produced by compiling
-XS, L<Inline>, or similar code.
-
-=item script
-
-Programs written in pure Perl. In order to improve reuse, try to make
-these as small as possible - put the code into modules whenever
-possible.
-
-=item bin
-
-"Architecture-dependent" executable programs, i.e. compiled C code or
-something. Pretty rare to see this in a perl distribution, but it
-happens.
-
-=item bindoc
-
-Documentation for the stuff in C<script> and C<bin>. Usually
-generated from the POD in those files. Under Unix, these are manual
-pages belonging to the 'man1' category.
-
-=item libdoc
-
-Documentation for the stuff in C<lib> and C<arch>. This is usually
-generated from the POD in F<.pm> files. Under Unix, these are manual
-pages belonging to the 'man3' category.
-
-=item binhtml
-
-This is the same as C<bindoc> above, but applies to HTML documents.
-
-=item libhtml
-
-This is the same as C<libdoc> above, but applies to HTML documents.
-
-=back
-
-Four other parameters let you control various aspects of how
-installation paths are determined:
-
-=over 4
-
-=item installdirs
-
-The default destinations for these installable things come from
-entries in your system's C<Config.pm>. You can select from three
-different sets of default locations by setting the C<installdirs>
-parameter as follows:
-
- 'installdirs' set to:
- core site vendor
-
- uses the following defaults from Config.pm:
-
- lib => installprivlib installsitelib installvendorlib
- arch => installarchlib installsitearch installvendorarch
- script => installscript installsitescript installvendorscript
- bin => installbin installsitebin installvendorbin
- bindoc => installman1dir installsiteman1dir installvendorman1dir
- libdoc => installman3dir installsiteman3dir installvendorman3dir
- binhtml => installhtml1dir installsitehtml1dir installvendorhtml1dir [*]
- libhtml => installhtml3dir installsitehtml3dir installvendorhtml3dir [*]
-
- * Under some OS (eg. MSWin32) the destination for HTML documents is
- determined by the C<Config.pm> entry C<installhtmldir>.
-
-The default value of C<installdirs> is "site". If you're creating
-vendor distributions of module packages, you may want to do something
-like this:
-
- perl Build.PL --installdirs vendor
-
-or
-
- ./Build install --installdirs vendor
-
-If you're installing an updated version of a module that was included
-with perl itself (i.e. a "core module"), then you may set
-C<installdirs> to "core" to overwrite the module in its present
-location.
-
-(Note that the 'script' line is different from C<MakeMaker> -
-unfortunately there's no such thing as "installsitescript" or
-"installvendorscript" entry in C<Config.pm>, so we use the
-"installsitebin" and "installvendorbin" entries to at least get the
-general location right. In the future, if C<Config.pm> adds some more
-appropriate entries, we'll start using those.)
-
-=item install_path
-
-Once the defaults have been set, you can override them.
-
-On the command line, that would look like this:
-
- perl Build.PL --install_path lib=/foo/lib --install_path arch=/foo/lib/arch
-
-or this:
-
- ./Build install --install_path lib=/foo/lib --install_path arch=/foo/lib/arch
-
-=item install_base
-
-You can also set the whole bunch of installation paths by supplying the
-C<install_base> parameter to point to a directory on your system. For
-instance, if you set C<install_base> to "/home/ken" on a Linux
-system, you'll install as follows:
-
- lib => /home/ken/lib/perl5
- arch => /home/ken/lib/perl5/i386-linux
- script => /home/ken/bin
- bin => /home/ken/bin
- bindoc => /home/ken/man/man1
- libdoc => /home/ken/man/man3
- binhtml => /home/ken/html
- libhtml => /home/ken/html
-
-Note that this is I<different> from how C<MakeMaker>'s C<PREFIX>
-parameter works. C<install_base> just gives you a default layout under the
-directory you specify, which may have little to do with the
-C<installdirs=site> layout.
-
-The exact layout under the directory you specify may vary by system -
-we try to do the "sensible" thing on each platform.
-
-=item destdir
-
-If you want to install everything into a temporary directory first
-(for instance, if you want to create a directory tree that a package
-manager like C<rpm> or C<dpkg> could create a package from), you can
-use the C<destdir> parameter:
-
- perl Build.PL --destdir /tmp/foo
-
-or
-
- ./Build install --destdir /tmp/foo
-
-This will effectively install to "/tmp/foo/$sitelib",
-"/tmp/foo/$sitearch", and the like, except that it will use
-C<File::Spec> to make the pathnames work correctly on whatever
-platform you're installing on.
-
-=item prefix
-
-Provided for compatibility with C<ExtUtils::MakeMaker>'s PREFIX argument.
-C<prefix> should be used when you want Module::Build to install your
-modules, documentation, and scripts in the same place as
-C<ExtUtils::MakeMaker>'s PREFIX mechanism.
-
-The following are equivalent.
-
- perl Build.PL --prefix /tmp/foo
- perl Makefile.PL PREFIX=/tmp/foo
-
-Because of the complex nature of the prefixification logic, the
-behavior of PREFIX in C<MakeMaker> has changed subtly over time.
-Module::Build's --prefix logic is equivalent to the PREFIX logic found
-in C<ExtUtils::MakeMaker> 6.30.
-
-The maintainers of C<MakeMaker> do understand the troubles with the
-PREFIX mechanism, and added INSTALL_BASE support in version 6.31 of
-C<MakeMaker>, which was released in 2006.
-
-If you don't need to retain compatibility with old versions (pre-6.31) of C<ExtUtils::MakeMaker> or
-are starting a fresh Perl installation we recommend you use
-C<install_base> instead (and C<INSTALL_BASE> in C<ExtUtils::MakeMaker>).
-See L<Module::Build::Cookbook/Installing in the same location as
-ExtUtils::MakeMaker> for further information.
-
-
-=back
-
-
-=head1 MOTIVATIONS
-
-There are several reasons I wanted to start over, and not just fix
-what I didn't like about C<MakeMaker>:
-
-=over 4
-
-=item *
-
-I don't like the core idea of C<MakeMaker>, namely that C<make> should be
-involved in the build process. Here are my reasons:
-
-=over 4
-
-=item +
-
-When a person is installing a Perl module, what can you assume about
-their environment? Can you assume they have C<make>? No, but you can
-assume they have some version of Perl.
-
-=item +
-
-When a person is writing a Perl module for intended distribution, can
-you assume that they know how to build a Makefile, so they can
-customize their build process? No, but you can assume they know Perl,
-and could customize that way.
-
-=back
-
-For years, these things have been a barrier to people getting the
-build/install process to do what they want.
-
-=item *
-
-There are several architectural decisions in C<MakeMaker> that make it
-very difficult to customize its behavior. For instance, when using
-C<MakeMaker> you do C<use ExtUtils::MakeMaker>, but the object created in
-C<WriteMakefile()> is actually blessed into a package name that's
-created on the fly, so you can't simply subclass
-C<ExtUtils::MakeMaker>. There is a workaround C<MY> package that lets
-you override certain C<MakeMaker> methods, but only certain explicitly
-preselected (by C<MakeMaker>) methods can be overridden. Also, the method
-of customization is very crude: you have to modify a string containing
-the Makefile text for the particular target. Since these strings
-aren't documented, and I<can't> be documented (they take on different
-values depending on the platform, version of perl, version of
-C<MakeMaker>, etc.), you have no guarantee that your modifications will
-work on someone else's machine or after an upgrade of C<MakeMaker> or
-perl.
-
-=item *
-
-It is risky to make major changes to C<MakeMaker>, since it does so many
-things, is so important, and generally works. C<Module::Build> is an
-entirely separate package so that I can work on it all I want, without
-worrying about backward compatibility with C<MakeMaker>.
-
-=item *
-
-Finally, Perl is said to be a language for system administration.
-Could it really be the case that Perl isn't up to the task of building
-and installing software? Even if that software is a bunch of
-C<.pm> files that just need to be copied from one place to
-another? My sense was that we could design a system to accomplish
-this in a flexible, extensible, and friendly manner. Or die trying.
-
-=back
-
-
-=head1 TO DO
-
-The current method of relying on time stamps to determine whether a
-derived file is out of date isn't likely to scale well, since it
-requires tracing all dependencies backward, it runs into problems on
-NFS, and it's just generally flimsy. It would be better to use an MD5
-signature or the like, if available. See C<cons> for an example.
-
- - append to perllocal.pod
- - add a 'plugin' functionality
-
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-Development questions, bug reports, and patches should be sent to the
-Module-Build mailing list at <module-build@perl.org>.
-
-Bug reports are also welcome at
-<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build>.
-
-The latest development version is available from the Git
-repository at <https://github.com/Perl-Toolchain-Gang/Module-Build>
-
-
-=head1 COPYRIGHT
-
-Copyright (c) 2001-2006 Ken Williams. All rights reserved.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-
-=head1 SEE ALSO
-
-perl(1), L<Module::Build::Cookbook>, L<Module::Build::Authoring>,
-L<Module::Build::API>, L<ExtUtils::MakeMaker>
-
-F<META.yml> Specification:
-L<CPAN::Meta::Spec>
-
-L<http://www.dsmit.com/cons/>
-
-L<http://search.cpan.org/dist/PerlBuildSystem/>
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Module::Build::API - API Reference for Module Authors
-
-=for :stopwords apache bsd distdir distsign gpl installdirs lgpl mit mozilla packlists
-
-=head1 DESCRIPTION
-
-I list here some of the most important methods in C<Module::Build>.
-Normally you won't need to deal with these methods unless you want to
-subclass C<Module::Build>. But since one of the reasons I created
-this module in the first place was so that subclassing is possible
-(and easy), I will certainly write more docs as the interface
-stabilizes.
-
-
-=head2 CONSTRUCTORS
-
-=over 4
-
-=item current()
-
-[version 0.20]
-
-This method returns a reasonable facsimile of the currently-executing
-C<Module::Build> object representing the current build. You can use
-this object to query its L</notes()> method, inquire about installed
-modules, and so on. This is a great way to share information between
-different parts of your build process. For instance, you can ask
-the user a question during C<perl Build.PL>, then use their answer
-during a regression test:
-
- # In Build.PL:
- my $color = $build->prompt("What is your favorite color?");
- $build->notes(color => $color);
-
- # In t/colortest.t:
- use Module::Build;
- my $build = Module::Build->current;
- my $color = $build->notes('color');
- ...
-
-The way the C<current()> method is currently implemented, there may be
-slight differences between the C<$build> object in Build.PL and the
-one in C<t/colortest.t>. It is our goal to minimize these differences
-in future releases of Module::Build, so please report any anomalies
-you find.
-
-One important caveat: in its current implementation, C<current()> will
-B<NOT> work correctly if you have changed out of the directory that
-C<Module::Build> was invoked from.
-
-=item new()
-
-[version 0.03]
-
-Creates a new Module::Build object. Arguments to the new() method are
-listed below. Most arguments are optional, but you must provide
-either the L</module_name> argument, or L</dist_name> and one of
-L</dist_version> or L</dist_version_from>. In other words, you must
-provide enough information to determine both a distribution name and
-version.
-
-
-=over 4
-
-=item add_to_cleanup
-
-[version 0.19]
-
-An array reference of files to be cleaned up when the C<clean> action
-is performed. See also the L<add_to_cleanup()|/"add_to_cleanup(@files)">
-method.
-
-=item allow_pureperl
-
-[version 0.4005]
-
-A bool indicating the module is still functional without its xs parts.
-When an XS module is build with --pureperl_only, it will otherwise fail.
-
-=item auto_configure_requires
-
-[version 0.34]
-
-This parameter determines whether Module::Build will add itself
-automatically to configure_requires (and build_requires) if Module::Build
-is not already there. The required version will be the last 'major' release,
-as defined by the decimal version truncated to two decimal places (e.g. 0.34,
-instead of 0.3402). The default value is true.
-
-=item auto_features
-
-[version 0.26]
-
-This parameter supports the setting of features (see
-L</feature($name)>) automatically based on a set of prerequisites. For
-instance, for a module that could optionally use either MySQL or
-PostgreSQL databases, you might use C<auto_features> like this:
-
- my $build = Module::Build->new
- (
- ...other stuff here...
- auto_features => {
- pg_support => {
- description => "Interface with Postgres databases",
- requires => { 'DBD::Pg' => 23.3,
- 'DateTime::Format::Pg' => 0 },
- },
- mysql_support => {
- description => "Interface with MySQL databases",
- requires => { 'DBD::mysql' => 17.9,
- 'DateTime::Format::MySQL' => 0 },
- },
- }
- );
-
-For each feature named, the required prerequisites will be checked, and
-if there are no failures, the feature will be enabled (set to C<1>).
-Otherwise the failures will be displayed to the user and the feature
-will be disabled (set to C<0>).
-
-See the documentation for L</requires> for the details of how
-requirements can be specified.
-
-=item autosplit
-
-[version 0.04]
-
-An optional C<autosplit> argument specifies a file which should be run
-through the L<AutoSplit::autosplit()|AutoSplit/autosplit> function.
-If multiple files should be split, the argument may be given as an
-array of the files to split.
-
-In general I don't consider autosplitting a great idea, because it's
-not always clear that autosplitting achieves its intended performance
-benefits. It may even harm performance in environments like mod_perl,
-where as much as possible of a module's code should be loaded during
-startup.
-
-=item build_class
-
-[version 0.28]
-
-The Module::Build class or subclass to use in the build script.
-Defaults to "Module::Build" or the class name passed to or created by
-a call to L</subclass()>. This property is useful if you're
-writing a custom Module::Build subclass and have a bootstrapping
-problem--that is, your subclass requires modules that may not be
-installed when C<perl Build.PL> is executed, but you've listed in
-L</build_requires> so that they should be available when C<./Build> is
-executed.
-
-=item build_requires
-
-[version 0.07]
-
-Modules listed in this section are necessary to build and install the
-given module, but are not necessary for regular usage of it. This is
-actually an important distinction - it allows for tighter control over
-the body of installed modules, and facilitates correct dependency
-checking on binary/packaged distributions of the module.
-
-See the documentation for L<Module::Build::Authoring/"PREREQUISITES">
-for the details of how requirements can be specified.
-
-=item configure_requires
-
-[version 0.30]
-
-Modules listed in this section must be installed I<before> configuring
-this distribution (i.e. before running the F<Build.PL> script).
-This might be a specific minimum version of C<Module::Build> or any
-other module the F<Build.PL> needs in order to do its stuff. Clients
-like C<CPAN.pm> or C<CPANPLUS> will be expected to pick
-C<configure_requires> out of the F<META.yml> file and install these
-items before running the C<Build.PL>.
-
-Module::Build may automatically add itself to configure_requires.
-See L</auto_configure_requires> for details.
-
-See the documentation for L<Module::Build::Authoring/"PREREQUISITES">
-for the details of how requirements can be specified.
-
-=item test_requires
-
-[version 0.4004]
-
-Modules listed in this section must be installed before testing the distribution.
-
-See the documentation for L<Module::Build::Authoring/"PREREQUISITES">
-for the details of how requirements can be specified.
-
-=item create_packlist
-
-[version 0.28]
-
-If true, this parameter tells Module::Build to create a F<.packlist>
-file during the C<install> action, just like C<ExtUtils::MakeMaker> does.
-The file is created in a subdirectory of the C<arch> installation
-location. It is used by some other tools (CPAN, CPANPLUS, etc.) for
-determining what files are part of an install.
-
-The default value is true. This parameter was introduced in
-Module::Build version 0.2609; previously no packlists were ever
-created by Module::Build.
-
-=item c_source
-
-[version 0.04]
-
-An optional C<c_source> argument specifies a directory which contains
-C source files that the rest of the build may depend on. Any C<.c>
-files in the directory will be compiled to object files. The
-directory will be added to the search path during the compilation and
-linking phases of any C or XS files.
-
-[version 0.3604]
-
-A list of directories can be supplied using an anonymous array
-reference of strings.
-
-=item conflicts
-
-[version 0.07]
-
-Modules listed in this section conflict in some serious way with the
-given module. C<Module::Build> (or some higher-level tool) will
-refuse to install the given module if the given module/version is also
-installed.
-
-See the documentation for L<Module::Build::Authoring/"PREREQUISITES">
-for the details of how requirements can be specified.
-
-=item create_license
-
-[version 0.31]
-
-This parameter tells Module::Build to automatically create a
-F<LICENSE> file at the top level of your distribution, containing the
-full text of the author's chosen license. This requires
-C<Software::License> on the author's machine, and further requires
-that the C<license> parameter specifies a license that it knows about.
-
-=item create_makefile_pl
-
-[version 0.19]
-
-This parameter lets you use C<Module::Build::Compat> during the
-C<distdir> (or C<dist>) action to automatically create a Makefile.PL
-for compatibility with C<ExtUtils::MakeMaker>. The parameter's value
-should be one of the styles named in the L<Module::Build::Compat>
-documentation.
-
-=item create_readme
-
-[version 0.22]
-
-This parameter tells Module::Build to automatically create a F<README>
-file at the top level of your distribution. Currently it will simply
-use C<Pod::Text> (or C<Pod::Readme> if it's installed) on the file
-indicated by C<dist_version_from> and put the result in the F<README>
-file. This is by no means the only recommended style for writing a
-F<README>, but it seems to be one common one used on the CPAN.
-
-If you generate a F<README> in this way, it's probably a good idea to
-create a separate F<INSTALL> file if that information isn't in the
-generated F<README>.
-
-=item dist_abstract
-
-[version 0.20]
-
-This should be a short description of the distribution. This is used when
-generating metadata for F<META.yml> and PPD files. If it is not given
-then C<Module::Build> looks in the POD of the module from which it gets
-the distribution's version. If it finds a POD section marked "=head1
-NAME", then it looks for the first line matching C<\s+-\s+(.+)>,
-and uses the captured text as the abstract.
-
-=item dist_author
-
-[version 0.20]
-
-This should be something like "John Doe <jdoe@example.com>", or if
-there are multiple authors, an anonymous array of strings may be
-specified. This is used when generating metadata for F<META.yml> and
-PPD files. If this is not specified, then C<Module::Build> looks at
-the module from which it gets the distribution's version. If it finds
-a POD section marked "=head1 AUTHOR", then it uses the contents of
-this section.
-
-=item dist_name
-
-[version 0.11]
-
-Specifies the name for this distribution. Most authors won't need to
-set this directly, they can use C<module_name> to set C<dist_name> to
-a reasonable default. However, some agglomerative distributions like
-C<libwww-perl> or C<bioperl> have names that don't correspond directly
-to a module name, so C<dist_name> can be set independently.
-
-=item dist_suffix
-
-[version 0.37]
-
-Specifies an optional suffix to include after the version number
-in the distribution directory (and tarball) name. The only suffix
-currently recognized by PAUSE is 'TRIAL', which indicates that the
-distribution should not be indexed. For example:
-
- Foo-Bar-1.23-TRIAL.tar.gz
-
-This will automatically do the "right thing" depending on C<dist_version> and
-C<release_status>. When C<dist_version> does not have an underscore and
-C<release_status> is not 'stable', then C<dist_suffix> will default to 'TRIAL'.
-Otherwise it will default to the empty string, disabling the suffix.
-
-In general, authors should only set this if they B<must> override the default
-behavior for some particular purpose.
-
-=item dist_version
-
-[version 0.11]
-
-Specifies a version number for the distribution. See L</module_name>
-or L</dist_version_from> for ways to have this set automatically from a
-C<$VERSION> variable in a module. One way or another, a version
-number needs to be set.
-
-=item dist_version_from
-
-[version 0.11]
-
-Specifies a file to look for the distribution version in. Most
-authors won't need to set this directly, they can use L</module_name>
-to set it to a reasonable default.
-
-The version is extracted from the specified file according to the same
-rules as L<ExtUtils::MakeMaker> and C<CPAN.pm>. It involves finding
-the first line that matches the regular expression
-
- /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/
-
-eval()-ing that line, then checking the value of the C<$VERSION>
-variable. Quite ugly, really, but all the modules on CPAN depend on
-this process, so there's no real opportunity to change to something
-better.
-
-If the target file of L</dist_version_from> contains more than one package
-declaration, the version returned will be the one matching the configured
-L</module_name>.
-
-=item dynamic_config
-
-[version 0.07]
-
-A boolean flag indicating whether the F<Build.PL> file must be
-executed, or whether this module can be built, tested and installed
-solely from consulting its metadata file. The main reason to set this
-to a true value is that your module performs some dynamic
-configuration as part of its build/install process. If the flag is
-omitted, the F<META.yml> spec says that installation tools should
-treat it as 1 (true), because this is a safer way to behave.
-
-Currently C<Module::Build> doesn't actually do anything with this flag
-- it's up to higher-level tools like C<CPAN.pm> to do something useful
-with it. It can potentially bring lots of security, packaging, and
-convenience improvements.
-
-=item extra_compiler_flags
-
-=item extra_linker_flags
-
-[version 0.19]
-
-These parameters can contain array references (or strings, in which
-case they will be split into arrays) to pass through to the compiler
-and linker phases when compiling/linking C code. For example, to tell
-the compiler that your code is C++, you might do:
-
- my $build = Module::Build->new
- (
- module_name => 'Foo::Bar',
- extra_compiler_flags => ['-x', 'c++'],
- );
-
-To link your XS code against glib you might write something like:
-
- my $build = Module::Build->new
- (
- module_name => 'Foo::Bar',
- dynamic_config => 1,
- extra_compiler_flags => scalar `glib-config --cflags`,
- extra_linker_flags => scalar `glib-config --libs`,
- );
-
-=item extra_manify_args
-
-[version 0.4006]
-
-Any extra arguments to pass to C<< Pod::Man->new() >> when building
-man pages. One common choice might be C<< utf8 => 1 >> to get Unicode
-support.
-
-=item get_options
-
-[version 0.26]
-
-You can pass arbitrary command line options to F<Build.PL> or
-F<Build>, and they will be stored in the Module::Build object and can
-be accessed via the L</args()> method. However, sometimes you want
-more flexibility out of your argument processing than this allows. In
-such cases, use the C<get_options> parameter to pass in a hash
-reference of argument specifications, and the list of arguments to
-F<Build.PL> or F<Build> will be processed according to those
-specifications before they're passed on to C<Module::Build>'s own
-argument processing.
-
-The supported option specification hash keys are:
-
-
-=over 4
-
-=item type
-
-The type of option. The types are those supported by Getopt::Long; consult
-its documentation for a complete list. Typical types are C<=s> for strings,
-C<+> for additive options, and C<!> for negatable options. If the
-type is not specified, it will be considered a boolean, i.e. no
-argument is taken and a value of 1 will be assigned when the option is
-encountered.
-
-=item store
-
-A reference to a scalar in which to store the value passed to the option.
-If not specified, the value will be stored under the option name in the
-hash returned by the C<args()> method.
-
-=item default
-
-A default value for the option. If no default value is specified and no option
-is passed, then the option key will not exist in the hash returned by
-C<args()>.
-
-=back
-
-
-You can combine references to your own variables or subroutines with
-unreferenced specifications, for which the result will also be stored in the
-hash returned by C<args()>. For example:
-
- my $loud = 0;
- my $build = Module::Build->new
- (
- module_name => 'Foo::Bar',
- get_options => {
- Loud => { store => \$loud },
- Dbd => { type => '=s' },
- Quantity => { type => '+' },
- }
- );
-
- print STDERR "HEY, ARE YOU LISTENING??\n" if $loud;
- print "We'll use the ", $build->args('Dbd'), " DBI driver\n";
- print "Are you sure you want that many?\n"
- if $build->args('Quantity') > 2;
-
-The arguments for such a specification can be called like so:
-
- perl Build.PL --Loud --Dbd=DBD::pg --Quantity --Quantity --Quantity
-
-B<WARNING:> Any option specifications that conflict with Module::Build's own
-options (defined by its properties) will throw an exception. Use capitalized
-option names to avoid unintended conflicts with future Module::Build options.
-
-Consult the Getopt::Long documentation for details on its usage.
-
-=item include_dirs
-
-[version 0.24]
-
-Specifies any additional directories in which to search for C header
-files. May be given as a string indicating a single directory, or as
-a list reference indicating multiple directories.
-
-=item install_path
-
-[version 0.19]
-
-You can set paths for individual installable elements by using the
-C<install_path> parameter:
-
- my $build = Module::Build->new
- (
- ...other stuff here...
- install_path => {
- lib => '/foo/lib',
- arch => '/foo/lib/arch',
- }
- );
-
-=item installdirs
-
-[version 0.19]
-
-Determines where files are installed within the normal perl hierarchy
-as determined by F<Config.pm>. Valid values are: C<core>, C<site>,
-C<vendor>. The default is C<site>. See
-L<Module::Build/"INSTALL PATHS">
-
-=item license
-
-[version 0.07]
-
-Specifies the licensing terms of your distribution.
-
-As of Module::Build version 0.36_14, you may use a L<Software::License>
-subclass name (e.g. 'Apache_2_0') instead of one of the keys below.
-
-The legacy list of valid license values include:
-
-=over 4
-
-=item apache
-
-The distribution is licensed under the Apache License, Version 2.0
-(L<http://apache.org/licenses/LICENSE-2.0>).
-
-=item apache_1_1
-
-The distribution is licensed under the Apache Software License, Version 1.1
-(L<http://apache.org/licenses/LICENSE-1.1>).
-
-=item artistic
-
-The distribution is licensed under the Artistic License, as specified
-by the F<Artistic> file in the standard Perl distribution.
-
-=item artistic_2
-
-The distribution is licensed under the Artistic 2.0 License
-(L<http://opensource.org/licenses/artistic-license-2.0.php>.)
-
-=item bsd
-
-The distribution is licensed under the BSD License
-(L<http://www.opensource.org/licenses/bsd-license.php>).
-
-=item gpl
-
-The distribution is licensed under the terms of the GNU General
-Public License (L<http://www.opensource.org/licenses/gpl-license.php>).
-
-=item lgpl
-
-The distribution is licensed under the terms of the GNU Lesser
-General Public License
-(L<http://www.opensource.org/licenses/lgpl-license.php>).
-
-=item mit
-
-The distribution is licensed under the MIT License
-(L<http://opensource.org/licenses/mit-license.php>).
-
-=item mozilla
-
-The distribution is licensed under the Mozilla Public
-License. (L<http://opensource.org/licenses/mozilla1.0.php> or
-L<http://opensource.org/licenses/mozilla1.1.php>)
-
-=item open_source
-
-The distribution is licensed under some other Open Source
-Initiative-approved license listed at
-L<http://www.opensource.org/licenses/>.
-
-=item perl
-
-The distribution may be copied and redistributed under the same terms
-as Perl itself (this is by far the most common licensing option for
-modules on CPAN). This is a dual license, in which the user may
-choose between either the GPL or the Artistic license.
-
-=item restrictive
-
-The distribution may not be redistributed without special permission
-from the author and/or copyright holder.
-
-=item unrestricted
-
-The distribution is licensed under a license that is B<not> approved
-by www.opensource.org but that allows distribution without
-restrictions.
-
-=back
-
-Note that you must still include the terms of your license in your
-code and documentation - this field only sets the information that is included
-in distribution metadata to let automated tools figure out your
-licensing restrictions. Humans still need something to read. If you
-choose to provide this field, you should make sure that you keep it in
-sync with your written documentation if you ever change your licensing
-terms.
-
-You may also use a license type of C<unknown> if you don't wish to
-specify your terms in the metadata.
-
-Also see the C<create_license> parameter.
-
-=item meta_add
-
-[version 0.28]
-
-A hash of key/value pairs that should be added to the F<META.yml> file
-during the C<distmeta> action. Any existing entries with the same
-names will be overridden.
-
-See the L</"MODULE METADATA"> section for details.
-
-=item meta_merge
-
-[version 0.28]
-
-A hash of key/value pairs that should be merged into the F<META.yml>
-file during the C<distmeta> action. Any existing entries with the
-same names will be overridden.
-
-The only difference between C<meta_add> and C<meta_merge> is their
-behavior on hash-valued and array-valued entries: C<meta_add> will
-completely blow away the existing hash or array value, but
-C<meta_merge> will merge the supplied data into the existing hash or
-array value.
-
-See the L</"MODULE METADATA"> section for details.
-
-=item module_name
-
-[version 0.03]
-
-The C<module_name> is a shortcut for setting default values of
-C<dist_name> and C<dist_version_from>, reflecting the fact that the
-majority of CPAN distributions are centered around one "main" module.
-For instance, if you set C<module_name> to C<Foo::Bar>, then
-C<dist_name> will default to C<Foo-Bar> and C<dist_version_from> will
-default to C<lib/Foo/Bar.pm>. C<dist_version_from> will in turn be
-used to set C<dist_version>.
-
-Setting C<module_name> won't override a C<dist_*> parameter you
-specify explicitly.
-
-=item needs_compiler
-
-[version 0.36]
-
-The C<needs_compiler> parameter indicates whether a compiler is required to
-build the distribution. The default is false, unless XS files are found or
-the C<c_source> parameter is set, in which case it is true. If true,
-L<ExtUtils::CBuilder> is automatically added to C<build_requires> if needed.
-
-For a distribution where a compiler is I<optional>, e.g. a dual XS/pure-Perl
-distribution, C<needs_compiler> should explicitly be set to a false value.
-
-=item PL_files
-
-[version 0.06]
-
-An optional parameter specifying a set of C<.PL> files in your
-distribution. These will be run as Perl scripts prior to processing
-the rest of the files in your distribution with the name of the file
-they're generating as an argument. They are usually used as templates
-for creating other files dynamically, so that a file like
-C<lib/Foo/Bar.pm.PL> might create the file C<lib/Foo/Bar.pm>.
-
-The files are specified with the C<.PL> files as hash keys, and the
-file(s) they generate as hash values, like so:
-
- my $build = Module::Build->new
- (
- module_name => 'Foo::Bar',
- ...
- PL_files => { 'lib/Foo/Bar.pm.PL' => 'lib/Foo/Bar.pm' },
- );
-
-Note that the path specifications are I<always> given in Unix-like
-format, not in the style of the local system.
-
-If your C<.PL> scripts don't create any files, or if they create files
-with unexpected names, or even if they create multiple files, you can
-indicate that so that Module::Build can properly handle these created
-files:
-
- PL_files => {
- 'lib/Foo/Bar.pm.PL' => 'lib/Foo/Bar.pm',
- 'lib/something.PL' => ['/lib/something', '/lib/else'],
- 'lib/funny.PL' => [],
- }
-
-Here's an example of a simple PL file.
-
- my $output_file = shift;
- open my $fh, ">", $output_file or die "Can't open $output_file: $!";
-
- print $fh <<'END';
- #!/usr/bin/perl
-
- print "Hello, world!\n";
- END
-
-PL files are not installed by default, so its safe to put them in
-F<lib/> and F<bin/>.
-
-
-=item pm_files
-
-[version 0.19]
-
-An optional parameter specifying the set of C<.pm> files in this
-distribution, specified as a hash reference whose keys are the files'
-locations in the distributions, and whose values are their logical
-locations based on their package name, i.e. where they would be found
-in a "normal" Module::Build-style distribution. This parameter is
-mainly intended to support alternative layouts of files.
-
-For instance, if you have an old-style C<MakeMaker> distribution for a
-module called C<Foo::Bar> and a F<Bar.pm> file at the top level of the
-distribution, you could specify your layout in your C<Build.PL> like
-this:
-
- my $build = Module::Build->new
- (
- module_name => 'Foo::Bar',
- ...
- pm_files => { 'Bar.pm' => 'lib/Foo/Bar.pm' },
- );
-
-Note that the values should include C<lib/>, because this is where
-they would be found in a "normal" Module::Build-style distribution.
-
-Note also that the path specifications are I<always> given in
-Unix-like format, not in the style of the local system.
-
-=item pod_files
-
-[version 0.19]
-
-Just like C<pm_files>, but used for specifying the set of C<.pod>
-files in your distribution.
-
-=item recommends
-
-[version 0.08]
-
-This is just like the L</requires> argument, except that modules listed
-in this section aren't essential, just a good idea. We'll just print
-a friendly warning if one of these modules aren't found, but we'll
-continue running.
-
-If a module is recommended but not required, all tests should still
-pass if the module isn't installed. This may mean that some tests
-may be skipped if recommended dependencies aren't present.
-
-Automated tools like CPAN.pm should inform the user when recommended
-modules aren't installed, and it should offer to install them if it
-wants to be helpful.
-
-See the documentation for L<Module::Build::Authoring/"PREREQUISITES">
-for the details of how requirements can be specified.
-
-=item recursive_test_files
-
-[version 0.28]
-
-Normally, C<Module::Build> does not search subdirectories when looking
-for tests to run. When this options is set it will search recursively
-in all subdirectories of the standard 't' test directory.
-
-=item release_status
-
-[version 0.37]
-
-The CPAN Meta Spec version 2 adds C<release_status> to allow authors
-to specify how a distribution should be indexed. Consistent with the
-spec, this parameter can only have one three values: 'stable',
-'testing' or 'unstable'.
-
-Unless explicitly set by the author, C<release_status> will default
-to 'stable' unless C<dist_version> contains an underscore, in which
-case it will default to 'testing'.
-
-It is an error to specify a C<release_status> of 'stable' when
-C<dist_version> contains an underscore character.
-
-=item requires
-
-[version 0.07]
-
-An optional C<requires> argument specifies any module prerequisites
-that the current module depends on.
-
-One note: currently C<Module::Build> doesn't actually I<require> the
-user to have dependencies installed, it just strongly urges. In the
-future we may require it. There's also a L</recommends> section for
-things that aren't absolutely required.
-
-Automated tools like CPAN.pm should refuse to install a module if one
-of its dependencies isn't satisfied, unless a "force" command is given
-by the user. If the tools are helpful, they should also offer to
-install the dependencies.
-
-A synonym for C<requires> is C<prereq>, to help succour people
-transitioning from C<ExtUtils::MakeMaker>. The C<requires> term is
-preferred, but the C<prereq> term will remain valid in future
-distributions.
-
-See the documentation for L<Module::Build::Authoring/"PREREQUISITES">
-for the details of how requirements can be specified.
-
-=item script_files
-
-[version 0.18]
-
-An optional parameter specifying a set of files that should be
-installed as executable Perl scripts when the module is installed.
-May be given as an array reference of the files, as a hash reference
-whose keys are the files (and whose values will currently be ignored),
-as a string giving the name of a directory in which to find scripts,
-or as a string giving the name of a single script file.
-
-The default is to install any scripts found in a F<bin> directory at
-the top level of the distribution, minus any keys of L<PL_files>.
-
-For backward compatibility, you may use the parameter C<scripts>
-instead of C<script_files>. Please consider this usage deprecated,
-though it will continue to exist for several version releases.
-
-=item share_dir
-
-[version 0.36]
-
-An optional parameter specifying directories of static data files to
-be installed as read-only files for use with L<File::ShareDir>. The
-C<share_dir> property supports both distribution-level and
-module-level share files.
-
-The simplest use of C<share_dir> is to set it to a directory name or an
-arrayref of directory names containing files to be installed in the
-distribution-level share directory.
-
- share_dir => 'share'
-
-Alternatively, if C<share_dir> is a hashref, it may have C<dist> or
-C<module> keys providing full flexibility in defining how share
-directories should be installed.
-
- share_dir => {
- dist => [ 'examples', 'more_examples' ],
- module => {
- Foo::Templates => ['share/html', 'share/text'],
- Foo::Config => 'share/config',
- }
- }
-
-If C<share_dir> is set, then File::ShareDir will automatically be added
-to the C<requires> hash.
-
-=item sign
-
-[version 0.16]
-
-If a true value is specified for this parameter, L<Module::Signature>
-will be used (via the 'distsign' action) to create a SIGNATURE file
-for your distribution during the 'distdir' action, and to add the
-SIGNATURE file to the MANIFEST (therefore, don't add it yourself).
-
-The default value is false. In the future, the default may change to
-true if you have C<Module::Signature> installed on your system.
-
-=item tap_harness_args
-
-[version 0.2808_03]
-
-An optional parameter specifying parameters to be passed to TAP::Harness when
-running tests. Must be given as a hash reference of parameters; see the
-L<TAP::Harness|TAP::Harness> documentation for details. Note that specifying
-this parameter will implicitly set C<use_tap_harness> to a true value. You
-must therefore be sure to add TAP::Harness as a requirement for your module in
-L</build_requires>.
-
-=item test_files
-
-[version 0.23]
-
-An optional parameter specifying a set of files that should be used as
-C<Test::Harness>-style regression tests to be run during the C<test>
-action. May be given as an array reference of the files, or as a hash
-reference whose keys are the files (and whose values will currently be
-ignored). If the argument is given as a single string (not in an
-array reference), that string will be treated as a C<glob()> pattern
-specifying the files to use.
-
-The default is to look for a F<test.pl> script in the top-level
-directory of the distribution, and any files matching the glob pattern
-C<*.t> in the F<t/> subdirectory. If the C<recursive_test_files>
-property is true, then the C<t/> directory will be scanned recursively
-for C<*.t> files.
-
-=item use_tap_harness
-
-[version 0.2808_03]
-
-An optional parameter indicating whether or not to use TAP::Harness for
-testing rather than Test::Harness. Defaults to false. If set to true, you must
-therefore be sure to add TAP::Harness as a requirement for your module in
-L</build_requires>. Implicitly set to a true value if C<tap_harness_args> is
-specified.
-
-=item xs_files
-
-[version 0.19]
-
-Just like C<pm_files>, but used for specifying the set of C<.xs>
-files in your distribution.
-
-=back
-
-
-=item new_from_context(%args)
-
-[version 0.28]
-
-When called from a directory containing a F<Build.PL> script (in other words,
-the base directory of a distribution), this method will run the F<Build.PL> and
-call C<resume()> to return the resulting C<Module::Build> object to the caller.
-Any key-value arguments given to C<new_from_context()> are essentially like
-command line arguments given to the F<Build.PL> script, so for example you
-could pass C<< verbose => 1 >> to this method to turn on verbosity.
-
-=item resume()
-
-[version 0.03]
-
-You'll probably never call this method directly, it's only called from the
-auto-generated C<Build> script (and the C<new_from_context> method). The
-C<new()> method is only called once, when the user runs C<perl Build.PL>.
-Thereafter, when the user runs C<Build test> or another action, the
-C<Module::Build> object is created using the C<resume()> method to
-re-instantiate with the settings given earlier to C<new()>.
-
-=item subclass()
-
-[version 0.06]
-
-This creates a new C<Module::Build> subclass on the fly, as described
-in the L<Module::Build::Authoring/"SUBCLASSING"> section. The caller
-must provide either a C<class> or C<code> parameter, or both. The
-C<class> parameter indicates the name to use for the new subclass, and
-defaults to C<MyModuleBuilder>. The C<code> parameter specifies Perl
-code to use as the body of the subclass.
-
-=item add_property
-
-[version 0.31]
-
- package 'My::Build';
- use base 'Module::Build';
- __PACKAGE__->add_property( 'pedantic' );
- __PACKAGE__->add_property( answer => 42 );
- __PACKAGE__->add_property(
- 'epoch',
- default => sub { time },
- check => sub {
- return 1 if /^\d+$/;
- shift->property_error( "'$_' is not an epoch time" );
- return 0;
- },
- );
-
-Adds a property to a Module::Build class. Properties are those attributes of a
-Module::Build object which can be passed to the constructor and which have
-accessors to get and set them. All of the core properties, such as
-C<module_name> and C<license>, are defined using this class method.
-
-The first argument to C<add_property()> is always the name of the property.
-The second argument can be either a default value for the property, or a list
-of key/value pairs. The supported keys are:
-
-=over
-
-=item C<default>
-
-The default value. May optionally be specified as a code reference, in which
-case the return value from the execution of the code reference will be used.
-If you need the default to be a code reference, just use a code reference to
-return it, e.g.:
-
- default => sub { sub { ... } },
-
-=item C<check>
-
-A code reference that checks that a value specified for the property is valid.
-During the execution of the code reference, the new value will be included in
-the C<$_> variable. If the value is correct, the C<check> code reference
-should return true. If the value is not correct, it sends an error message to
-C<property_error()> and returns false.
-
-=back
-
-When this method is called, a new property will be installed in the
-Module::Build class, and an accessor will be built to allow the property to be
-get or set on the build object.
-
- print $build->pedantic, $/;
- $build->pedantic(0);
-
-If the default value is a hash reference, this generates a special-case
-accessor method, wherein individual key/value pairs may be set or fetched:
-
- print "stuff{foo} is: ", $build->stuff( 'foo' ), $/;
- $build->stuff( foo => 'bar' );
- print $build->stuff( 'foo' ), $/; # Outputs "bar"
-
-Of course, you can still set the entire hash reference at once, as well:
-
- $build->stuff( { foo => 'bar', baz => 'yo' } );
-
-In either case, if a C<check> has been specified for the property, it will be
-applied to the entire hash. So the check code reference should look something
-like:
-
- check => sub {
- return 1 if defined $_ && exists $_->{foo};
- shift->property_error(qq{Property "stuff" needs "foo"});
- return 0;
- },
-
-=item property_error
-
-[version 0.31]
-
-=back
-
-
-=head2 METHODS
-
-=over 4
-
-=item add_build_element($type)
-
-[version 0.26]
-
-Adds a new type of entry to the build process. Accepts a single
-string specifying its type-name. There must also be a method defined
-to process things of that type, e.g. if you add a build element called
-C<'foo'>, then you must also define a method called
-C<process_foo_files()>.
-
-See also
-L<Module::Build::Cookbook/"Adding new file types to the build process">.
-
-=item add_to_cleanup(@files)
-
-[version 0.03]
-
-You may call C<< $self->add_to_cleanup(@patterns) >> to tell
-C<Module::Build> that certain files should be removed when the user
-performs the C<Build clean> action. The arguments to the method are
-patterns suitable for passing to Perl's C<glob()> function, specified
-in either Unix format or the current machine's native format. It's
-usually convenient to use Unix format when you hard-code the filenames
-(e.g. in F<Build.PL>) and the native format when the names are
-programmatically generated (e.g. in a testing script).
-
-I decided to provide a dynamic method of the C<$build> object, rather
-than just use a static list of files named in the F<Build.PL>, because
-these static lists can get difficult to manage. I usually prefer to
-keep the responsibility for registering temporary files close to the
-code that creates them.
-
-=item args()
-
-[version 0.26]
-
- my $args_href = $build->args;
- my %args = $build->args;
- my $arg_value = $build->args($key);
- $build->args($key, $value);
-
-This method is the preferred interface for retrieving the arguments passed via
-command line options to F<Build.PL> or F<Build>, minus the Module-Build
-specific options.
-
-When called in a scalar context with no arguments, this method returns a
-reference to the hash storing all of the arguments; in an array context, it
-returns the hash itself. When passed a single argument, it returns the value
-stored in the args hash for that option key. When called with two arguments,
-the second argument is assigned to the args hash under the key passed as the
-first argument.
-
-=item autosplit_file($from, $to)
-
-[version 0.28]
-
-Invokes the L<AutoSplit> module on the C<$from> file, sending the
-output to the C<lib/auto> directory inside C<$to>. C<$to> is
-typically the C<blib/> directory.
-
-=item base_dir()
-
-[version 0.14]
-
-Returns a string containing the root-level directory of this build,
-i.e. where the C<Build.PL> script and the C<lib> directory can be
-found. This is usually the same as the current working directory,
-because the C<Build> script will C<chdir()> into this directory as
-soon as it begins execution.
-
-=item build_requires()
-
-[version 0.21]
-
-Returns a hash reference indicating the C<build_requires>
-prerequisites that were passed to the C<new()> method.
-
-=item can_action( $action )
-
-Returns a reference to the method that defines C<$action>, or false
-otherwise. This is handy for actions defined (or maybe not!) in subclasses.
-
-[version 0.32_xx]
-
-=item cbuilder()
-
-[version 0.2809]
-
-Returns the internal ExtUtils::CBuilder object that can be used for
-compiling & linking C code. If no such object is available (e.g. if
-the system has no compiler installed) an exception will be thrown.
-
-=item check_installed_status($module, $version)
-
-[version 0.11]
-
-This method returns a hash reference indicating whether a version
-dependency on a certain module is satisfied. The C<$module> argument
-is given as a string like C<"Data::Dumper"> or C<"perl">, and the
-C<$version> argument can take any of the forms described in L</requires>
-above. This allows very fine-grained version checking.
-
-The returned hash reference has the following structure:
-
- {
- ok => $whether_the_dependency_is_satisfied,
- have => $version_already_installed,
- need => $version_requested, # Same as incoming $version argument
- message => $informative_error_message,
- }
-
-If no version of C<$module> is currently installed, the C<have> value
-will be the string C<< "<none>" >>. Otherwise the C<have> value will
-simply be the version of the installed module. Note that this means
-that if C<$module> is installed but doesn't define a version number,
-the C<have> value will be C<undef> - this is why we don't use C<undef>
-for the case when C<$module> isn't installed at all.
-
-This method may be called either as an object method
-(C<< $build->check_installed_status($module, $version) >>)
-or as a class method
-(C<< Module::Build->check_installed_status($module, $version) >>).
-
-=item check_installed_version($module, $version)
-
-[version 0.05]
-
-Like L<check_installed_status()|/"check_installed_status($module, $version)">,
-but simply returns true or false depending on whether module
-C<$module> satisfies the dependency C<$version>.
-
-If the check succeeds, the return value is the actual version of
-C<$module> installed on the system. This allows you to do the
-following:
-
- my $installed = $build->check_installed_version('DBI', '1.15');
- if ($installed) {
- print "Congratulations, version $installed of DBI is installed.\n";
- } else {
- die "Sorry, you must install DBI.\n";
- }
-
-If the check fails, we return false and set C<$@> to an informative
-error message.
-
-If C<$version> is any non-true value (notably zero) and any version of
-C<$module> is installed, we return true. In this case, if C<$module>
-doesn't define a version, or if its version is zero, we return the
-special value "0 but true", which is numerically zero, but logically
-true.
-
-In general you might prefer to use C<check_installed_status> if you
-need detailed information, or this method if you just need a yes/no
-answer.
-
-=item compare_versions($v1, $op, $v2)
-
-[version 0.28]
-
-Compares two module versions C<$v1> and C<$v2> using the operator
-C<$op>, which should be one of Perl's numeric operators like C<!=> or
-C<< >= >> or the like. We do at least a halfway-decent job of
-handling versions that aren't strictly numeric, like C<0.27_02>, but
-exotic stuff will likely cause problems.
-
-In the future, the guts of this method might be replaced with a call
-out to C<version.pm>.
-
-=item config($key)
-
-=item config($key, $value)
-
-=item config() [deprecated]
-
-[version 0.22]
-
-With a single argument C<$key>, returns the value associated with that
-key in the C<Config.pm> hash, including any changes the author or user
-has specified.
-
-With C<$key> and C<$value> arguments, sets the value for future
-callers of C<config($key)>.
-
-With no arguments, returns a hash reference containing all such
-key-value pairs. This usage is deprecated, though, because it's a
-resource hog and violates encapsulation.
-
-=item config_data($name)
-
-=item config_data($name => $value)
-
-[version 0.26]
-
-With a single argument, returns the value of the configuration
-variable C<$name>. With two arguments, sets the given configuration
-variable to the given value. The value may be any Perl scalar that's
-serializable with C<Data::Dumper>. For instance, if you write a
-module that can use a MySQL or PostgreSQL back-end, you might create
-configuration variables called C<mysql_connect> and
-C<postgres_connect>, and set each to an array of connection parameters
-for C<< DBI->connect() >>.
-
-Configuration values set in this way using the Module::Build object
-will be available for querying during the build/test process and after
-installation via the generated C<...::ConfigData> module, as
-C<< ...::ConfigData->config($name) >>.
-
-The L<feature()|/"feature($name)"> and C<config_data()> methods represent
-Module::Build's main support for configuration of installed modules.
-See also L<Module::Build::Authoring/"SAVING CONFIGURATION INFORMATION">.
-
-=item conflicts()
-
-[version 0.21]
-
-Returns a hash reference indicating the C<conflicts> prerequisites
-that were passed to the C<new()> method.
-
-=item contains_pod($file) [deprecated]
-
-[version 0.20]
-
-[Deprecated] Please see L<Module::Build::ModuleInfo> instead.
-
-Returns true if the given file appears to contain POD documentation.
-Currently this checks whether the file has a line beginning with
-'=pod', '=head', or '=item', but the exact semantics may change in the
-future.
-
-=item copy_if_modified(%parameters)
-
-[version 0.19]
-
-Takes the file in the C<from> parameter and copies it to the file in
-the C<to> parameter, or the directory in the C<to_dir> parameter, if
-the file has changed since it was last copied (or if it doesn't exist
-in the new location). By default the entire directory structure of
-C<from> will be copied into C<to_dir>; an optional C<flatten>
-parameter will copy into C<to_dir> without doing so.
-
-Returns the path to the destination file, or C<undef> if nothing
-needed to be copied.
-
-Any directories that need to be created in order to perform the
-copying will be automatically created.
-
-The destination file is set to read-only. If the source file has the
-executable bit set, then the destination file will be made executable.
-
-=item create_build_script()
-
-[version 0.05]
-
-Creates an executable script called C<Build> in the current directory
-that will be used to execute further user actions. This script is
-roughly analogous (in function, not in form) to the Makefile created
-by C<ExtUtils::MakeMaker>. This method also creates some temporary
-data in a directory called C<_build/>. Both of these will be removed
-when the C<realclean> action is performed.
-
-Among the files created in C<_build/> is a F<_build/prereqs> file
-containing the set of prerequisites for this distribution, as a hash
-of hashes. This file may be C<eval()>-ed to obtain the authoritative
-set of prerequisites, which might be different from the contents of
-F<META.yml> (because F<Build.PL> might have set them dynamically).
-But fancy developers take heed: do not put any fancy custom runtime
-code in the F<_build/prereqs> file, leave it as a static declaration
-containing only strings and numbers. Similarly, do not alter the
-structure of the internal C<< $self->{properties}{requires} >> (etc.)
-data members, because that's where this data comes from.
-
-=item current_action()
-
-[version 0.28]
-
-Returns the name of the currently-running action, such as "build" or
-"test". This action is not necessarily the action that was originally
-invoked by the user. For example, if the user invoked the "test"
-action, current_action() would initially return "test". However,
-action "test" depends on action "code", so current_action() will
-return "code" while that dependency is being executed. Once that
-action has completed, current_action() will again return "test".
-
-If you need to know the name of the original action invoked by the
-user, see L</invoked_action()> below.
-
-=item depends_on(@actions)
-
-[version 0.28]
-
-Invokes the named action or list of actions in sequence. Using this
-method is preferred to calling the action explicitly because it
-performs some internal record-keeping, and it ensures that the same
-action is not invoked multiple times (note: in future versions of
-Module::Build it's conceivable that this run-only-once mechanism will
-be changed to something more intelligent).
-
-Note that the name of this method is something of a misnomer; it
-should really be called something like
-C<invoke_actions_unless_already_invoked()> or something, but for
-better or worse (perhaps better!) we were still thinking in
-C<make>-like dependency terms when we created this method.
-
-See also L<dispatch()|/"dispatch($action, %args)">. The main
-distinction between the two is that C<depends_on()> is meant to call
-an action from inside another action, whereas C<dispatch()> is meant
-to set the very top action in motion.
-
-=item dir_contains($first_dir, $second_dir)
-
-[version 0.28]
-
-Returns true if the first directory logically contains the second
-directory. This is just a convenience function because C<File::Spec>
-doesn't really provide an easy way to figure this out (but
-C<Path::Class> does...).
-
-=item dispatch($action, %args)
-
-[version 0.03]
-
-Invokes the build action C<$action>. Optionally, a list of options
-and their values can be passed in. This is equivalent to invoking an
-action at the command line, passing in a list of options.
-
-Custom options that have not been registered must be passed in as a
-hash reference in a key named "args":
-
- $build->dispatch('foo', verbose => 1, args => { my_option => 'value' });
-
-This method is intended to be used to programmatically invoke build
-actions, e.g. by applications controlling Module::Build-based builds
-rather than by subclasses.
-
-See also L<depends_on()|/"depends_on(@actions)">. The main
-distinction between the two is that C<depends_on()> is meant to call
-an action from inside another action, whereas C<dispatch()> is meant
-to set the very top action in motion.
-
-=item dist_dir()
-
-[version 0.28]
-
-Returns the name of the directory that will be created during the
-C<dist> action. The name is derived from the C<dist_name> and
-C<dist_version> properties.
-
-=item dist_name()
-
-[version 0.21]
-
-Returns the name of the current distribution, as passed to the
-C<new()> method in a C<dist_name> or modified C<module_name>
-parameter.
-
-=item dist_version()
-
-[version 0.21]
-
-Returns the version of the current distribution, as determined by the
-C<new()> method from a C<dist_version>, C<dist_version_from>, or
-C<module_name> parameter.
-
-=item do_system($cmd, @args)
-
-[version 0.21]
-
-This is a fairly simple wrapper around Perl's C<system()> built-in
-command. Given a command and an array of optional arguments, this
-method will print the command to C<STDOUT>, and then execute it using
-Perl's C<system()>. It returns true or false to indicate success or
-failure (the opposite of how C<system()> works, but more intuitive).
-
-Note that if you supply a single argument to C<do_system()>, it
-will/may be processed by the system's shell, and any special
-characters will do their special things. If you supply multiple
-arguments, no shell will get involved and the command will be executed
-directly.
-
-=item extra_compiler_flags()
-
-=item extra_compiler_flags(@flags)
-
-[version 0.25]
-
-Set or retrieve the extra compiler flags. Returns an arrayref of flags.
-
-=item extra_linker_flags()
-
-=item extra_linker_flags(@flags)
-
-[version 0.25]
-
-Set or retrieve the extra linker flags. Returns an arrayref of flags.
-
-=item feature($name)
-
-=item feature($name => $value)
-
-[version 0.26]
-
-With a single argument, returns true if the given feature is set.
-With two arguments, sets the given feature to the given boolean value.
-In this context, a "feature" is any optional functionality of an
-installed module. For instance, if you write a module that could
-optionally support a MySQL or PostgreSQL backend, you might create
-features called C<mysql_support> and C<postgres_support>, and set them
-to true/false depending on whether the user has the proper databases
-installed and configured.
-
-Features set in this way using the Module::Build object will be
-available for querying during the build/test process and after
-installation via the generated C<...::ConfigData> module, as
-C<< ...::ConfigData->feature($name) >>.
-
-The C<feature()> and C<config_data()> methods represent
-Module::Build's main support for configuration of installed modules.
-See also L<Module::Build::Authoring/"SAVING CONFIGURATION INFORMATION">.
-
-=item fix_shebang_line(@files)
-
-[version 0.??]
-
-Modify any "shebang" line in the specified files to use the path to the
-perl executable being used for the current build. Files are modified
-in-place. The existing shebang line must have a command that contains
-"C<perl>"; arguments to the command do not count. In particular, this
-means that the use of C<#!/usr/bin/env perl> will not be changed.
-
-For an explanation of shebang lines, see
-L<http://en.wikipedia.org/wiki/Shebang_%28Unix%29>.
-
-=item have_c_compiler()
-
-[version 0.21]
-
-Returns true if the current system seems to have a working C compiler.
-We currently determine this by attempting to compile a simple C source
-file and reporting whether the attempt was successful.
-
-=item install_base_relpaths()
-
-=item install_base_relpaths($type)
-
-=item install_base_relpaths($type => $path)
-
-[version 0.28]
-
-Set or retrieve the relative paths that are appended to
-C<install_base> for any installable element. This is useful if you
-want to set the relative install path for custom build elements.
-
-With no argument, it returns a reference to a hash containing all
-elements and their respective values. This hash should not be modified
-directly; use the multiple argument below form to change values.
-
-The single argument form returns the value associated with the
-element C<$type>.
-
-The multiple argument form allows you to set the paths for element types.
-C<$value> must be a relative path using Unix-like paths. (A series of
-directories separated by slashes, e.g. C<foo/bar>.) The return value is a
-localized path based on C<$value>.
-
-Assigning the value C<undef> to an element causes it to be removed.
-
-=item install_destination($type)
-
-[version 0.28]
-
-Returns the directory in which items of type C<$type> (e.g. C<lib>,
-C<arch>, C<bin>, or anything else returned by the L</install_types()>
-method) will be installed during the C<install> action. Any settings
-for C<install_path>, C<install_base>, and C<prefix> are taken into
-account when determining the return value.
-
-=item install_path()
-
-=item install_path($type)
-
-=item install_path($type => $path)
-
-[version 0.28]
-
-Set or retrieve paths for specific installable elements. This is
-useful when you want to examine any explicit install paths specified
-by the user on the command line, or if you want to set the install
-path for a specific installable element based on another attribute
-like C<install_base()>.
-
-With no argument, it returns a reference to a hash containing all
-elements and their respective values. This hash should not be modified
-directly; use the multiple argument below form to change values.
-
-The single argument form returns the value associated with the
-element C<$type>.
-
-The multiple argument form allows you to set the paths for element types.
-The supplied C<$path> should be an absolute path to install elements
-of C<$type>. The return value is C<$path>.
-
-Assigning the value C<undef> to an element causes it to be removed.
-
-=item install_types()
-
-[version 0.28]
-
-Returns a list of installable types that this build knows about.
-These types each correspond to the name of a directory in F<blib/>,
-and the list usually includes items such as C<lib>, C<arch>, C<bin>,
-C<script>, C<libdoc>, C<bindoc>, and if HTML documentation is to be
-built, C<libhtml> and C<binhtml>. Other user-defined types may also
-exist.
-
-=item invoked_action()
-
-[version 0.28]
-
-This is the name of the original action invoked by the user. This
-value is set when the user invokes F<Build.PL>, the F<Build> script,
-or programmatically through the L<dispatch()|/"dispatch($action, %args)">
-method. It does not change as sub-actions are executed as
-dependencies are evaluated.
-
-To get the name of the currently executing dependency, see
-L</current_action()> above.
-
-=item notes()
-
-=item notes($key)
-
-=item notes($key => $value)
-
-[version 0.20]
-
-The C<notes()> value allows you to store your own persistent
-information about the build, and to share that information among
-different entities involved in the build. See the example in the
-C<current()> method.
-
-The C<notes()> method is essentially a glorified hash access. With no
-arguments, C<notes()> returns the entire hash of notes. With one argument,
-C<notes($key)> returns the value associated with the given key. With two
-arguments, C<notes($key, $value)> sets the value associated with the given key
-to C<$value> and returns the new value.
-
-The lifetime of the C<notes> data is for "a build" - that is, the
-C<notes> hash is created when C<perl Build.PL> is run (or when the
-C<new()> method is run, if the Module::Build Perl API is being used
-instead of called from a shell), and lasts until C<perl Build.PL> is
-run again or the C<clean> action is run.
-
-=item orig_dir()
-
-[version 0.28]
-
-Returns a string containing the working directory that was in effect
-before the F<Build> script chdir()-ed into the C<base_dir>. This
-might be useful for writing wrapper tools that might need to chdir()
-back out.
-
-=item os_type()
-
-[version 0.04]
-
-If you're subclassing Module::Build and some code needs to alter its
-behavior based on the current platform, you may only need to know
-whether you're running on Windows, Unix, MacOS, VMS, etc., and not the
-fine-grained value of Perl's C<$^O> variable. The C<os_type()> method
-will return a string like C<Windows>, C<Unix>, C<MacOS>, C<VMS>, or
-whatever is appropriate. If you're running on an unknown platform, it
-will return C<undef> - there shouldn't be many unknown platforms
-though.
-
-=item is_vmsish()
-
-=item is_windowsish()
-
-=item is_unixish()
-
-Convenience functions that return a boolean value indicating whether
-this platform behaves respectively like VMS, Windows, or Unix. For
-arbitrary reasons other platforms don't get their own such functions,
-at least not yet.
-
-
-=item prefix_relpaths()
-
-=item prefix_relpaths($installdirs)
-
-=item prefix_relpaths($installdirs, $type)
-
-=item prefix_relpaths($installdirs, $type => $path)
-
-[version 0.28]
-
-Set or retrieve the relative paths that are appended to C<prefix> for
-any installable element. This is useful if you want to set the
-relative install path for custom build elements.
-
-With no argument, it returns a reference to a hash containing all
-elements and their respective values as defined by the current
-C<installdirs> setting.
-
-With a single argument, it returns a reference to a hash containing
-all elements and their respective values as defined by
-C<$installdirs>.
-
-The hash returned by the above calls should not be modified directly;
-use the three-argument below form to change values.
-
-The two argument form returns the value associated with the
-element C<$type>.
-
-The multiple argument form allows you to set the paths for element types.
-C<$value> must be a relative path using Unix-like paths. (A series of
-directories separated by slashes, e.g. C<foo/bar>.) The return value is a
-localized path based on C<$value>.
-
-Assigning the value C<undef> to an element causes it to be removed.
-
-=item get_metadata()
-
-[version 0.36]
-
-This method returns a hash reference of metadata that can be used to create a
-YAML datastream. It is provided for authors to override or customize the fields
-of F<META.yml>. E.g.
-
- package My::Builder;
- use base 'Module::Build';
-
- sub get_metadata {
- my $self, @args = @_;
- my $data = $self->SUPER::get_metadata(@args);
- $data->{custom_field} = 'foo';
- return $data;
- }
-
-Valid arguments include:
-
-=over
-
-=item *
-
-C<fatal> -- indicates whether missing required
-metadata fields should be a fatal error or not. For META creation, it
-generally should, but for MYMETA creation for end-users, it should not be
-fatal.
-
-=item *
-
-C<auto> -- indicates whether any necessary configure_requires should be
-automatically added. This is used in META creation.
-
-=back
-
-This method is a wrapper around the old prepare_metadata API now that we
-no longer use YAML::Node to hold metadata.
-
-=item prepare_metadata() [deprecated]
-
-[version 0.36]
-
-[Deprecated] As of 0.36, authors should use C<get_metadata> instead. This
-method is preserved for backwards compatibility only.
-
-It takes three positional arguments: a hashref (to which metadata will be
-added), an optional arrayref (to which metadata keys will be added in order if
-the arrayref exists), and a hashref of arguments (as provided to get_metadata).
-The latter argument is new as of 0.36. Earlier versions are always fatal on
-errors.
-
-Prior to version 0.36, this method took a YAML::Node as an argument to hold
-assembled metadata.
-
-=item prereq_failures()
-
-[version 0.11]
-
-Returns a data structure containing information about any failed
-prerequisites (of any of the types described above), or C<undef> if
-all prerequisites are met.
-
-The data structure returned is a hash reference. The top level keys
-are the type of prerequisite failed, one of "requires",
-"build_requires", "conflicts", or "recommends". The associated values
-are hash references whose keys are the names of required (or
-conflicting) modules. The associated values of those are hash
-references indicating some information about the failure. For example:
-
- {
- have => '0.42',
- need => '0.59',
- message => 'Version 0.42 is installed, but we need version 0.59',
- }
-
-or
-
- {
- have => '<none>',
- need => '0.59',
- message => 'Prerequisite Foo isn't installed',
- }
-
-This hash has the same structure as the hash returned by the
-C<check_installed_status()> method, except that in the case of
-"conflicts" dependencies we change the "need" key to "conflicts" and
-construct a proper message.
-
-Examples:
-
- # Check a required dependency on Foo::Bar
- if ( $build->prereq_failures->{requires}{Foo::Bar} ) { ...
-
- # Check whether there were any failures
- if ( $build->prereq_failures ) { ...
-
- # Show messages for all failures
- my $failures = $build->prereq_failures;
- while (my ($type, $list) = each %$failures) {
- while (my ($name, $hash) = each %$list) {
- print "Failure for $name: $hash->{message}\n";
- }
- }
-
-=item prereq_data()
-
-[version 0.32]
-
-Returns a reference to a hash describing all prerequisites. The keys of the
-hash will be the various prerequisite types ('requires', 'build_requires',
-'test_requires', 'configure_requires', 'recommends', or 'conflicts') and the values will be
-references to hashes of module names and version numbers. Only prerequisites
-types that are defined will be included. The C<prereq_data> action is just a
-thin wrapper around the C<prereq_data()> method and dumps the hash as a string
-that can be loaded using C<eval()>.
-
-=item prereq_report()
-
-[version 0.28]
-
-Returns a human-readable (table-form) string showing all
-prerequisites, the versions required, and the versions actually
-installed. This can be useful for reviewing the configuration of your
-system prior to a build, or when compiling data to send for a bug
-report. The C<prereq_report> action is just a thin wrapper around the
-C<prereq_report()> method.
-
-=item prompt($message, $default)
-
-[version 0.12]
-
-Asks the user a question and returns their response as a string. The
-first argument specifies the message to display to the user (for
-example, C<"Where do you keep your money?">). The second argument,
-which is optional, specifies a default answer (for example,
-C<"wallet">). The user will be asked the question once.
-
-If C<prompt()> detects that it is not running interactively and there
-is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable
-is set to true, the $default will be used without prompting.
-
-To prevent automated processes from blocking, the user must either set
-PERL_MM_USE_DEFAULT or attach something to STDIN (this can be a
-pipe/file containing a scripted set of answers or /dev/null.)
-
-If no $default is provided an empty string will be used instead. In
-non-interactive mode, the absence of $default is an error (though
-explicitly passing C<undef()> as the default is valid as of 0.27.)
-
-This method may be called as a class or object method.
-
-=item recommends()
-
-[version 0.21]
-
-Returns a hash reference indicating the C<recommends> prerequisites
-that were passed to the C<new()> method.
-
-=item requires()
-
-[version 0.21]
-
-Returns a hash reference indicating the C<requires> prerequisites that
-were passed to the C<new()> method.
-
-=item rscan_dir($dir, $pattern)
-
-[version 0.28]
-
-Uses C<File::Find> to traverse the directory C<$dir>, returning a
-reference to an array of entries matching C<$pattern>. C<$pattern>
-may either be a regular expression (using C<qr//> or just a plain
-string), or a reference to a subroutine that will return true for
-wanted entries. If C<$pattern> is not given, all entries will be
-returned.
-
-Examples:
-
- # All the *.pm files in lib/
- $m->rscan_dir('lib', qr/\.pm$/)
-
- # All the files in blib/ that aren't *.html files
- $m->rscan_dir('blib', sub {-f $_ and not /\.html$/});
-
- # All the files in t/
- $m->rscan_dir('t');
-
-=item runtime_params()
-
-=item runtime_params($key)
-
-[version 0.28]
-
-The C<runtime_params()> method stores the values passed on the command line
-for valid properties (that is, any command line options for which
-C<valid_property()> returns a true value). The value on the command line may
-override the default value for a property, as well as any value specified in a
-call to C<new()>. This allows you to programmatically tell if C<perl Build.PL>
-or any execution of C<./Build> had command line options specified that
-override valid properties.
-
-The C<runtime_params()> method is essentially a glorified read-only hash. With
-no arguments, C<runtime_params()> returns the entire hash of properties
-specified on the command line. With one argument, C<runtime_params($key)>
-returns the value associated with the given key.
-
-The lifetime of the C<runtime_params> data is for "a build" - that is, the
-C<runtime_params> hash is created when C<perl Build.PL> is run (or when the
-C<new()> method is called, if the Module::Build Perl API is being used instead
-of called from a shell), and lasts until C<perl Build.PL> is run again or the
-C<clean> action is run.
-
-=item script_files()
-
-[version 0.18]
-
-Returns a hash reference whose keys are the perl script files to be
-installed, if any. This corresponds to the C<script_files> parameter to the
-C<new()> method. With an optional argument, this parameter may be set
-dynamically.
-
-For backward compatibility, the C<scripts()> method does exactly the
-same thing as C<script_files()>. C<scripts()> is deprecated, but it
-will stay around for several versions to give people time to
-transition.
-
-=item up_to_date($source_file, $derived_file)
-
-=item up_to_date(\@source_files, \@derived_files)
-
-[version 0.20]
-
-This method can be used to compare a set of source files to a set of
-derived files. If any of the source files are newer than any of the
-derived files, it returns false. Additionally, if any of the derived
-files do not exist, it returns false. Otherwise it returns true.
-
-The arguments may be either a scalar or an array reference of file
-names.
-
-=item y_n($message, $default)
-
-[version 0.12]
-
-Asks the user a yes/no question using C<prompt()> and returns true or
-false accordingly. The user will be asked the question repeatedly
-until they give an answer that looks like "yes" or "no".
-
-The first argument specifies the message to display to the user (for
-example, C<"Shall I invest your money for you?">), and the second
-argument specifies the default answer (for example, C<"y">).
-
-Note that the default is specified as a string like C<"y"> or C<"n">,
-and the return value is a Perl boolean value like 1 or 0. I thought
-about this for a while and this seemed like the most useful way to do
-it.
-
-This method may be called as a class or object method.
-
-=back
-
-
-=head2 Autogenerated Accessors
-
-In addition to the aforementioned methods, there are also some get/set
-accessor methods for the following properties:
-
-=over 4
-
-=item PL_files()
-
-=item allow_mb_mismatch()
-
-=item allow_pureperl()
-
-=item auto_configure_requires()
-
-=item autosplit()
-
-=item base_dir()
-
-=item bindoc_dirs()
-
-=item blib()
-
-=item build_bat()
-
-=item build_class()
-
-=item build_elements()
-
-=item build_requires()
-
-=item build_script()
-
-=item bundle_inc()
-
-=item bundle_inc_preload()
-
-=item c_source()
-
-=item config_dir()
-
-=item configure_requires()
-
-=item conflicts()
-
-=item cpan_client()
-
-=item create_license()
-
-=item create_makefile_pl()
-
-=item create_packlist()
-
-=item create_readme()
-
-=item debug()
-
-=item debugger()
-
-=item destdir()
-
-=item dynamic_config()
-
-=item extra_manify_args()
-
-=item get_options()
-
-=item html_css()
-
-=item include_dirs()
-
-=item install_base()
-
-=item installdirs()
-
-=item libdoc_dirs()
-
-=item license()
-
-=item magic_number()
-
-=item mb_version()
-
-=item meta_add()
-
-=item meta_merge()
-
-=item metafile()
-
-=item metafile2()
-
-=item module_name()
-
-=item mymetafile()
-
-=item mymetafile2()
-
-=item needs_compiler()
-
-=item orig_dir()
-
-=item perl()
-
-=item pm_files()
-
-=item pod_files()
-
-=item pollute()
-
-=item prefix()
-
-=item prereq_action_types()
-
-=item program_name()
-
-=item pureperl_only()
-
-=item quiet()
-
-=item recommends()
-
-=item recurse_into()
-
-=item recursive_test_files()
-
-=item requires()
-
-=item scripts()
-
-=item sign()
-
-=item tap_harness_args()
-
-=item test_file_exts()
-
-=item test_requires()
-
-=item use_rcfile()
-
-=item use_tap_harness()
-
-=item verbose()
-
-=item xs_files()
-
-=back
-
-=head1 MODULE METADATA
-
-If you would like to add other useful metadata, C<Module::Build>
-supports this with the C<meta_add> and C<meta_merge> arguments to
-L</new()>. The authoritative list of supported metadata can be found at
-L<CPAN::Meta::Spec> but for convenience - here are a few of the more useful ones:
-
-=over 4
-
-=item keywords
-
-For describing the distribution using keyword (or "tags") in order to
-make CPAN.org indexing and search more efficient and useful.
-
-=item resources
-
-A list of additional resources available for users of the
-distribution. This can include links to a homepage on the web, a
-bug tracker, the repository location, and even a subscription page for the
-distribution mailing list.
-
-=back
-
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-
-=head1 COPYRIGHT
-
-Copyright (c) 2001-2006 Ken Williams. All rights reserved.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-
-=head1 SEE ALSO
-
-perl(1), L<Module::Build>(3), L<Module::Build::Authoring>(3),
-L<Module::Build::Cookbook>(3), L<ExtUtils::MakeMaker>(3)
-
-F<META.yml> Specification:
-L<CPAN::Meta::Spec>
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Module::Build::Authoring - Authoring Module::Build modules
-
-=head1 DESCRIPTION
-
-When creating a C<Build.PL> script for a module, something like the
-following code will typically be used:
-
- use Module::Build;
- my $build = Module::Build->new
- (
- module_name => 'Foo::Bar',
- license => 'perl',
- requires => {
- 'perl' => '5.6.1',
- 'Some::Module' => '1.23',
- 'Other::Module' => '>= 1.2, != 1.5, < 2.0',
- },
- );
- $build->create_build_script;
-
-A simple module could get away with something as short as this for its
-C<Build.PL> script:
-
- use Module::Build;
- Module::Build->new(
- module_name => 'Foo::Bar',
- license => 'perl',
- )->create_build_script;
-
-The model used by C<Module::Build> is a lot like the C<MakeMaker>
-metaphor, with the following correspondences:
-
- In Module::Build In ExtUtils::MakeMaker
- --------------------------- ------------------------
- Build.PL (initial script) Makefile.PL (initial script)
- Build (a short perl script) Makefile (a long Makefile)
- _build/ (saved state info) various config text in the Makefile
-
-Any customization can be done simply by subclassing C<Module::Build>
-and adding a method called (for example) C<ACTION_test>, overriding
-the default 'test' action. You could also add a method called
-C<ACTION_whatever>, and then you could perform the action C<Build
-whatever>.
-
-For information on providing compatibility with
-C<ExtUtils::MakeMaker>, see L<Module::Build::Compat> and
-L<http://www.makemaker.org/wiki/index.cgi?ModuleBuildConversionGuide>.
-
-
-=head1 STRUCTURE
-
-Module::Build creates a class hierarchy conducive to customization.
-Here is the parent-child class hierarchy in classy ASCII art:
-
- /--------------------\
- | Your::Parent | (If you subclass Module::Build)
- \--------------------/
- |
- |
- /--------------------\ (Doesn't define any functionality
- | Module::Build | of its own - just figures out what
- \--------------------/ other modules to load.)
- |
- |
- /-----------------------------------\ (Some values of $^O may
- | Module::Build::Platform::$^O | define specialized functionality.
- \-----------------------------------/ Otherwise it's ...::Default, a
- | pass-through class.)
- |
- /--------------------------\
- | Module::Build::Base | (Most of the functionality of
- \--------------------------/ Module::Build is defined here.)
-
-
-=head1 SUBCLASSING
-
-Right now, there are two ways to subclass Module::Build. The first
-way is to create a regular module (in a C<.pm> file) that inherits
-from Module::Build, and use that module's class instead of using
-Module::Build directly:
-
- ------ in Build.PL: ----------
- #!/usr/bin/perl
-
- use lib q(/nonstandard/library/path);
- use My::Builder; # Or whatever you want to call it
-
- my $build = My::Builder->new
- (
- module_name => 'Foo::Bar', # All the regular args...
- license => 'perl',
- dist_author => 'A N Other <me@here.net.au>',
- requires => { Carp => 0 }
- );
- $build->create_build_script;
-
-This is relatively straightforward, and is the best way to do things
-if your My::Builder class contains lots of code. The
-C<create_build_script()> method will ensure that the current value of
-C<@INC> (including the C</nonstandard/library/path>) is propagated to
-the Build script, so that My::Builder can be found when running build
-actions. If you find that you need to C<chdir> into a different directories
-in your subclass methods or actions, be sure to always return to the original
-directory (available via the C<base_dir()> method) before returning control
-to the parent class. This is important to avoid data serialization problems.
-
-For very small additions, Module::Build provides a C<subclass()>
-method that lets you subclass Module::Build more conveniently, without
-creating a separate file for your module:
-
- ------ in Build.PL: ----------
- #!/usr/bin/perl
-
- use Module::Build;
- my $class = Module::Build->subclass
- (
- class => 'My::Builder',
- code => q{
- sub ACTION_foo {
- print "I'm fooing to death!\n";
- }
- },
- );
-
- my $build = $class->new
- (
- module_name => 'Foo::Bar', # All the regular args...
- license => 'perl',
- dist_author => 'A N Other <me@here.net.au>',
- requires => { Carp => 0 }
- );
- $build->create_build_script;
-
-Behind the scenes, this actually does create a C<.pm> file, since the
-code you provide must persist after Build.PL is run if it is to be
-very useful.
-
-See also the documentation for the L<Module::Build::API/"subclass()">
-method.
-
-
-=head1 PREREQUISITES
-
-=head2 Types of prerequisites
-
-To specify what versions of other modules are used by this
-distribution, several types of prerequisites can be defined with the
-following parameters:
-
-=over 3
-
-=item configure_requires
-
-Items that must be installed I<before> configuring this distribution
-(i.e. before running the F<Build.PL> script). This might be a
-specific minimum version of C<Module::Build> or any other module the
-F<Build.PL> needs in order to do its stuff. Clients like C<CPAN.pm>
-or C<CPANPLUS> will be expected to pick C<configure_requires> out of the
-F<META.yml> file and install these items before running the
-C<Build.PL>.
-
-If no configure_requires is specified, the current version of Module::Build
-is automatically added to configure_requires.
-
-=item build_requires
-
-Items that are necessary for building and testing this distribution,
-but aren't necessary after installation. This can help users who only
-want to install these items temporarily. It also helps reduce the
-size of the CPAN dependency graph if everything isn't smooshed into
-C<requires>.
-
-=item requires
-
-Items that are necessary for basic functioning.
-
-=item recommends
-
-Items that are recommended for enhanced functionality, but there are
-ways to use this distribution without having them installed. You
-might also think of this as "can use" or "is aware of" or "changes
-behavior in the presence of".
-
-=item test_requires
-
-Items that are necessary for testing.
-
-=item conflicts
-
-Items that can cause problems with this distribution when installed.
-This is pretty rare.
-
-=back
-
-=head2 Format of prerequisites
-
-The prerequisites are given in a hash reference, where the keys are
-the module names and the values are version specifiers:
-
- requires => {
- Foo::Module => '2.4',
- Bar::Module => 0,
- Ken::Module => '>= 1.2, != 1.5, < 2.0',
- perl => '5.6.0'
- },
-
-The above four version specifiers have different effects. The value
-C<'2.4'> means that B<at least> version 2.4 of C<Foo::Module> must be
-installed. The value C<0> means that B<any> version of C<Bar::Module>
-is acceptable, even if C<Bar::Module> doesn't define a version. The
-more verbose value C<'E<gt>= 1.2, != 1.5, E<lt> 2.0'> means that
-C<Ken::Module>'s version must be B<at least> 1.2, B<less than> 2.0,
-and B<not equal to> 1.5. The list of criteria is separated by commas,
-and all criteria must be satisfied.
-
-A special C<perl> entry lets you specify the versions of the Perl
-interpreter that are supported by your module. The same version
-dependency-checking semantics are available, except that we also
-understand perl's new double-dotted version numbers.
-
-=head2 XS Extensions
-
-Modules which need to compile XS code should list C<ExtUtils::CBuilder>
-as a C<build_requires> element.
-
-
-=head1 SAVING CONFIGURATION INFORMATION
-
-Module::Build provides a very convenient way to save configuration
-information that your installed modules (or your regression tests) can
-access. If your Build process calls the C<feature()> or
-C<config_data()> methods, then a C<Foo::Bar::ConfigData> module will
-automatically be created for you, where C<Foo::Bar> is the
-C<module_name> parameter as passed to C<new()>. This module provides
-access to the data saved by these methods, and a way to update the
-values. There is also a utility script called C<config_data>
-distributed with Module::Build that provides a command line interface
-to this same functionality. See also the generated
-C<Foo::Bar::ConfigData> documentation, and the C<config_data>
-script's documentation, for more information.
-
-
-=head1 STARTING MODULE DEVELOPMENT
-
-When starting development on a new module, it's rarely worth your time
-to create a tree of all the files by hand. Some automatic
-module-creators are available: the oldest is C<h2xs>, which has
-shipped with perl itself for a long time. Its name reflects the fact
-that modules were originally conceived of as a way to wrap up a C
-library (thus the C<h> part) into perl extensions (thus the C<xs>
-part).
-
-These days, C<h2xs> has largely been superseded by modules like
-C<ExtUtils::ModuleMaker>, and C<Module::Starter>. They have varying
-degrees of support for C<Module::Build>.
-
-
-=head1 AUTOMATION
-
-One advantage of Module::Build is that since it's implemented as Perl
-methods, you can invoke these methods directly if you want to install
-a module non-interactively. For instance, the following Perl script
-will invoke the entire build/install procedure:
-
- my $build = Module::Build->new(module_name => 'MyModule');
- $build->dispatch('build');
- $build->dispatch('test');
- $build->dispatch('install');
-
-If any of these steps encounters an error, it will throw a fatal
-exception.
-
-You can also pass arguments as part of the build process:
-
- my $build = Module::Build->new(module_name => 'MyModule');
- $build->dispatch('build');
- $build->dispatch('test', verbose => 1);
- $build->dispatch('install', sitelib => '/my/secret/place/');
-
-Building and installing modules in this way skips creating the
-C<Build> script.
-
-
-=head1 MIGRATION
-
-Note that if you want to provide both a F<Makefile.PL> and a
-F<Build.PL> for your distribution, you probably want to add the
-following to C<WriteMakefile> in your F<Makefile.PL> so that C<MakeMaker>
-doesn't try to run your F<Build.PL> as a normal F<.PL> file:
-
- PL_FILES => {},
-
-You may also be interested in looking at the C<Module::Build::Compat>
-module, which can automatically create various kinds of F<Makefile.PL>
-compatibility layers.
-
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-Development questions, bug reports, and patches should be sent to the
-Module-Build mailing list at <module-build@perl.org>.
-
-Bug reports are also welcome at
-<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build>.
-
-The latest development version is available from the Git
-repository at <https://github.com/Perl-Toolchain-Gang/Module-Build>
-
-
-=head1 SEE ALSO
-
-perl(1), L<Module::Build>(3), L<Module::Build::API>(3),
-L<Module::Build::Cookbook>(3), L<ExtUtils::MakeMaker>(3), L<YAML>(3)
-
-F<META.yml> Specification:
-L<CPAN::Meta::Spec>
-
-L<http://www.dsmit.com/cons/>
-
-L<http://search.cpan.org/dist/PerlBuildSystem/>
-
-=cut
+++ /dev/null
-# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
-# vim:ts=8:sw=2:et:sta:sts=2
-package Module::Build::Base;
-
-use strict;
-use vars qw($VERSION);
-use warnings;
-
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-BEGIN { require 5.006001 }
-
-use Carp;
-use Cwd ();
-use File::Copy ();
-use File::Find ();
-use File::Path ();
-use File::Basename ();
-use File::Spec 0.82 ();
-use File::Compare ();
-use Module::Build::Dumper ();
-use Text::ParseWords ();
-
-use Module::Build::ModuleInfo;
-use Module::Build::Notes;
-use Module::Build::Config;
-use Module::Build::Version;
-
-
-#################### Constructors ###########################
-sub new {
- my $self = shift()->_construct(@_);
-
- $self->{invoked_action} = $self->{action} ||= 'Build_PL';
- $self->cull_args(@ARGV);
-
- die "Too early to specify a build action '$self->{action}'. Do 'Build $self->{action}' instead.\n"
- if $self->{action} && $self->{action} ne 'Build_PL';
-
- $self->check_manifest;
- $self->auto_require;
-
- # All checks must run regardless if one fails, so no short circuiting!
- if( grep { !$_ } $self->check_prereq, $self->check_autofeatures ) {
- $self->log_warn(<<EOF);
-
-ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions
-of the modules indicated above before proceeding with this installation
-
-EOF
- unless (
- $self->dist_name eq 'Module-Build' ||
- $ENV{PERL5_CPANPLUS_IS_RUNNING} || $ENV{PERL5_CPAN_IS_RUNNING}
- ) {
- $self->log_warn(
- "Run 'Build installdeps' to install missing prerequisites.\n\n"
- );
- }
- }
-
- # record for later use in resume;
- $self->{properties}{_added_to_INC} = [ $self->_added_to_INC ];
-
- $self->set_bundle_inc;
-
- $self->dist_name;
- $self->dist_version;
- $self->release_status;
- $self->_guess_module_name unless $self->module_name;
-
- $self->_find_nested_builds;
-
- return $self;
-}
-
-sub resume {
- my $package = shift;
- my $self = $package->_construct(@_);
- $self->read_config;
-
- my @added_earlier = @{ $self->{properties}{_added_to_INC} || [] };
-
- @INC = ($self->_added_to_INC, @added_earlier, $self->_default_INC);
-
- # If someone called Module::Build->current() or
- # Module::Build->new_from_context() and the correct class to use is
- # actually a *subclass* of Module::Build, we may need to load that
- # subclass here and re-delegate the resume() method to it.
- unless ( UNIVERSAL::isa($package, $self->build_class) ) {
- my $build_class = $self->build_class;
- my $config_dir = $self->config_dir || '_build';
- my $build_lib = File::Spec->catdir( $config_dir, 'lib' );
- unshift( @INC, $build_lib );
- unless ( $build_class->can('new') ) {
- eval "require $build_class; 1" or die "Failed to re-load '$build_class': $@";
- }
- return $build_class->resume(@_);
- }
-
- unless ($self->_perl_is_same($self->{properties}{perl})) {
- my $perl = $self->find_perl_interpreter;
- die(<<"DIEFATAL");
-* FATAL ERROR: Perl interpreter mismatch. Configuration was initially
- created with '$self->{properties}{perl}'
- but we are now using '$perl'. You must
- run 'Build realclean' or 'make realclean' and re-configure.
-DIEFATAL
- }
-
- $self->cull_args(@ARGV);
-
- unless ($self->allow_mb_mismatch) {
- my $mb_version = $Module::Build::VERSION;
- if ( $mb_version ne $self->{properties}{mb_version} ) {
- $self->log_warn(<<"MISMATCH");
-* WARNING: Configuration was initially created with Module::Build
- version '$self->{properties}{mb_version}' but we are now using version '$mb_version'.
- If errors occur, you must re-run the Build.PL or Makefile.PL script.
-MISMATCH
- }
- }
-
- $self->{invoked_action} = $self->{action} ||= 'build';
-
- return $self;
-}
-
-sub new_from_context {
- my ($package, %args) = @_;
-
- $package->run_perl_script('Build.PL',[],[$package->unparse_args(\%args)]);
- return $package->resume;
-}
-
-sub current {
- # hmm, wonder what the right thing to do here is
- local @ARGV;
- return shift()->resume;
-}
-
-sub _construct {
- my ($package, %input) = @_;
-
- my $args = delete $input{args} || {};
- my $config = delete $input{config} || {};
-
- my $self = bless {
- args => {%$args},
- config => Module::Build::Config->new(values => $config),
- properties => {
- base_dir => $package->cwd,
- mb_version => $Module::Build::VERSION,
- %input,
- },
- phash => {},
- stash => {}, # temporary caching, not stored in _build
- }, $package;
-
- $self->_set_defaults;
- my ($p, $ph) = ($self->{properties}, $self->{phash});
-
- foreach (qw(notes config_data features runtime_params cleanup auto_features)) {
- my $file = File::Spec->catfile($self->config_dir, $_);
- $ph->{$_} = Module::Build::Notes->new(file => $file);
- $ph->{$_}->restore if -e $file;
- if (exists $p->{$_}) {
- my $vals = delete $p->{$_};
- while (my ($k, $v) = each %$vals) {
- $self->$_($k, $v);
- }
- }
- }
-
- # The following warning could be unnecessary if the user is running
- # an embedded perl, but there aren't too many of those around, and
- # embedded perls aren't usually used to install modules, and the
- # installation process sometimes needs to run external scripts
- # (e.g. to run tests).
- $p->{perl} = $self->find_perl_interpreter
- or $self->log_warn("Warning: Can't locate your perl binary");
-
- my $blibdir = sub { File::Spec->catdir($p->{blib}, @_) };
- $p->{bindoc_dirs} ||= [ $blibdir->("script") ];
- $p->{libdoc_dirs} ||= [ $blibdir->("lib"), $blibdir->("arch") ];
-
- $p->{dist_author} = [ $p->{dist_author} ] if defined $p->{dist_author} and not ref $p->{dist_author};
-
- # Synonyms
- $p->{requires} = delete $p->{prereq} if defined $p->{prereq};
- $p->{script_files} = delete $p->{scripts} if defined $p->{scripts};
-
- # Convert to from shell strings to arrays
- for ('extra_compiler_flags', 'extra_linker_flags') {
- $p->{$_} = [ $self->split_like_shell($p->{$_}) ] if exists $p->{$_};
- }
-
- # Convert to arrays
- for ('include_dirs') {
- $p->{$_} = [ $p->{$_} ] if exists $p->{$_} && !ref $p->{$_}
- }
-
- $self->add_to_cleanup( @{delete $p->{add_to_cleanup}} )
- if $p->{add_to_cleanup};
-
- return $self;
-}
-
-################## End constructors #########################
-
-sub log_info {
- my $self = shift;
- print @_ if ref($self) && ( $self->verbose || ! $self->quiet );
-}
-sub log_verbose {
- my $self = shift;
- print @_ if ref($self) && $self->verbose;
-}
-sub log_debug {
- my $self = shift;
- print @_ if ref($self) && $self->debug;
-}
-
-sub log_warn {
- # Try to make our call stack invisible
- shift;
- if (@_ and $_[-1] !~ /\n$/) {
- my (undef, $file, $line) = caller();
- warn @_, " at $file line $line.\n";
- } else {
- warn @_;
- }
-}
-
-
-# install paths must be generated when requested to be sure all changes
-# to config (from various sources) are included
-sub _default_install_paths {
- my $self = shift;
- my $c = $self->{config};
- my $p = {};
-
- my @libstyle = $c->get('installstyle') ?
- File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
- my $arch = $c->get('archname');
- my $version = $c->get('version');
-
- my $bindoc = $c->get('installman1dir') || undef;
- my $libdoc = $c->get('installman3dir') || undef;
-
- my $binhtml = $c->get('installhtml1dir') || $c->get('installhtmldir') || undef;
- my $libhtml = $c->get('installhtml3dir') || $c->get('installhtmldir') || undef;
-
- $p->{install_sets} =
- {
- core => {
- lib => $c->get('installprivlib'),
- arch => $c->get('installarchlib'),
- bin => $c->get('installbin'),
- script => $c->get('installscript'),
- bindoc => $bindoc,
- libdoc => $libdoc,
- binhtml => $binhtml,
- libhtml => $libhtml,
- },
- site => {
- lib => $c->get('installsitelib'),
- arch => $c->get('installsitearch'),
- bin => $c->get('installsitebin') || $c->get('installbin'),
- script => $c->get('installsitescript') ||
- $c->get('installsitebin') || $c->get('installscript'),
- bindoc => $c->get('installsiteman1dir') || $bindoc,
- libdoc => $c->get('installsiteman3dir') || $libdoc,
- binhtml => $c->get('installsitehtml1dir') || $binhtml,
- libhtml => $c->get('installsitehtml3dir') || $libhtml,
- },
- vendor => {
- lib => $c->get('installvendorlib'),
- arch => $c->get('installvendorarch'),
- bin => $c->get('installvendorbin') || $c->get('installbin'),
- script => $c->get('installvendorscript') ||
- $c->get('installvendorbin') || $c->get('installscript'),
- bindoc => $c->get('installvendorman1dir') || $bindoc,
- libdoc => $c->get('installvendorman3dir') || $libdoc,
- binhtml => $c->get('installvendorhtml1dir') || $binhtml,
- libhtml => $c->get('installvendorhtml3dir') || $libhtml,
- },
- };
-
- $p->{original_prefix} =
- {
- core => $c->get('installprefixexp') || $c->get('installprefix') ||
- $c->get('prefixexp') || $c->get('prefix') || '',
- site => $c->get('siteprefixexp'),
- vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '',
- };
- $p->{original_prefix}{site} ||= $p->{original_prefix}{core};
-
- # Note: you might be tempted to use $Config{installstyle} here
- # instead of hard-coding lib/perl5, but that's been considered and
- # (at least for now) rejected. `perldoc Config` has some wisdom
- # about it.
- $p->{install_base_relpaths} =
- {
- lib => ['lib', 'perl5'],
- arch => ['lib', 'perl5', $arch],
- bin => ['bin'],
- script => ['bin'],
- bindoc => ['man', 'man1'],
- libdoc => ['man', 'man3'],
- binhtml => ['html'],
- libhtml => ['html'],
- };
-
- $p->{prefix_relpaths} =
- {
- core => {
- lib => [@libstyle],
- arch => [@libstyle, $version, $arch],
- bin => ['bin'],
- script => ['bin'],
- bindoc => ['man', 'man1'],
- libdoc => ['man', 'man3'],
- binhtml => ['html'],
- libhtml => ['html'],
- },
- vendor => {
- lib => [@libstyle],
- arch => [@libstyle, $version, $arch],
- bin => ['bin'],
- script => ['bin'],
- bindoc => ['man', 'man1'],
- libdoc => ['man', 'man3'],
- binhtml => ['html'],
- libhtml => ['html'],
- },
- site => {
- lib => [@libstyle, 'site_perl'],
- arch => [@libstyle, 'site_perl', $version, $arch],
- bin => ['bin'],
- script => ['bin'],
- bindoc => ['man', 'man1'],
- libdoc => ['man', 'man3'],
- binhtml => ['html'],
- libhtml => ['html'],
- },
- };
- return $p
-}
-
-sub _find_nested_builds {
- my $self = shift;
- my $r = $self->recurse_into or return;
-
- my ($file, @r);
- if (!ref($r) && $r eq 'auto') {
- local *DH;
- opendir DH, $self->base_dir
- or die "Can't scan directory " . $self->base_dir . " for nested builds: $!";
- while (defined($file = readdir DH)) {
- my $subdir = File::Spec->catdir( $self->base_dir, $file );
- next unless -d $subdir;
- push @r, $subdir if -e File::Spec->catfile( $subdir, 'Build.PL' );
- }
- }
-
- $self->recurse_into(\@r);
-}
-
-sub cwd {
- return Cwd::cwd();
-}
-
-sub _quote_args {
- # Returns a string that can become [part of] a command line with
- # proper quoting so that the subprocess sees this same list of args.
- my ($self, @args) = @_;
-
- my @quoted;
-
- for (@args) {
- if ( /^[^\s*?!\$<>;\\|'"\[\]\{\}]+$/ ) {
- # Looks pretty safe
- push @quoted, $_;
- } else {
- # XXX this will obviously have to improve - is there already a
- # core module lying around that does proper quoting?
- s/('+)/'"$1"'/g;
- push @quoted, qq('$_');
- }
- }
-
- return join " ", @quoted;
-}
-
-sub _backticks {
- my ($self, @cmd) = @_;
- if ($self->have_forkpipe) {
- local *FH;
- my $pid = open *FH, "-|";
- if ($pid) {
- return wantarray ? <FH> : join '', <FH>;
- } else {
- die "Can't execute @cmd: $!\n" unless defined $pid;
- exec { $cmd[0] } @cmd;
- }
- } else {
- my $cmd = $self->_quote_args(@cmd);
- return `$cmd`;
- }
-}
-
-# Tells us whether the construct open($fh, '-|', @command) is
-# supported. It would probably be better to dynamically sense this.
-sub have_forkpipe { 1 }
-
-# Determine whether a given binary is the same as the perl
-# (configuration) that started this process.
-sub _perl_is_same {
- my ($self, $perl) = @_;
-
- my @cmd = ($perl);
-
- # When run from the perl core, @INC will include the directories
- # where perl is yet to be installed. We need to reference the
- # absolute path within the source distribution where it can find
- # it's Config.pm This also prevents us from picking up a Config.pm
- # from a different configuration that happens to be already
- # installed in @INC.
- if ($ENV{PERL_CORE}) {
- push @cmd, '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib');
- }
-
- push @cmd, qw(-MConfig=myconfig -e print -e myconfig);
- return $self->_backticks(@cmd) eq Config->myconfig;
-}
-
-# cache _discover_perl_interpreter() results
-{
- my $known_perl;
- sub find_perl_interpreter {
- my $self = shift;
-
- return $known_perl if defined($known_perl);
- return $known_perl = $self->_discover_perl_interpreter;
- }
-}
-
-# Returns the absolute path of the perl interpreter used to invoke
-# this process. The path is derived from $^X or $Config{perlpath}. On
-# some platforms $^X contains the complete absolute path of the
-# interpreter, on other it may contain a relative path, or simply
-# 'perl'. This can also vary depending on whether a path was supplied
-# when perl was invoked. Additionally, the value in $^X may omit the
-# executable extension on platforms that use one. It's a fatal error
-# if the interpreter can't be found because it can result in undefined
-# behavior by routines that depend on it (generating errors or
-# invoking the wrong perl.)
-sub _discover_perl_interpreter {
- my $proto = shift;
- my $c = ref($proto) ? $proto->{config} : 'Module::Build::Config';
-
- my $perl = $^X;
- my $perl_basename = File::Basename::basename($perl);
-
- my @potential_perls;
-
- # Try 1, Check $^X for absolute path
- push( @potential_perls, $perl )
- if File::Spec->file_name_is_absolute($perl);
-
- # Try 2, Check $^X for a valid relative path
- my $abs_perl = File::Spec->rel2abs($perl);
- push( @potential_perls, $abs_perl );
-
- # Try 3, Last ditch effort: These two option use hackery to try to locate
- # a suitable perl. The hack varies depending on whether we are running
- # from an installed perl or an uninstalled perl in the perl source dist.
- if ($ENV{PERL_CORE}) {
-
- # Try 3.A, If we are in a perl source tree, running an uninstalled
- # perl, we can keep moving up the directory tree until we find our
- # binary. We wouldn't do this under any other circumstances.
-
- # CBuilder is also in the core, so it should be available here
- require ExtUtils::CBuilder;
- my $perl_src = Cwd::realpath( ExtUtils::CBuilder->perl_src );
- if ( defined($perl_src) && length($perl_src) ) {
- my $uninstperl =
- File::Spec->rel2abs(File::Spec->catfile( $perl_src, $perl_basename ));
- push( @potential_perls, $uninstperl );
- }
-
- } else {
-
- # Try 3.B, First look in $Config{perlpath}, then search the user's
- # PATH. We do not want to do either if we are running from an
- # uninstalled perl in a perl source tree.
-
- push( @potential_perls, $c->get('perlpath') );
-
- push( @potential_perls,
- map File::Spec->catfile($_, $perl_basename), File::Spec->path() );
- }
-
- # Now that we've enumerated the potential perls, it's time to test
- # them to see if any of them match our configuration, returning the
- # absolute path of the first successful match.
- my $exe = $c->get('exe_ext');
- foreach my $thisperl ( @potential_perls ) {
-
- if (defined $exe) {
- $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
- }
-
- if ( -f $thisperl && $proto->_perl_is_same($thisperl) ) {
- return $thisperl;
- }
- }
-
- # We've tried all alternatives, and didn't find a perl that matches
- # our configuration. Throw an exception, and list alternatives we tried.
- my @paths = map File::Basename::dirname($_), @potential_perls;
- die "Can't locate the perl binary used to run this script " .
- "in (@paths)\n";
-}
-
-# Adapted from IPC::Cmd::can_run()
-sub find_command {
- my ($self, $command) = @_;
-
- if( File::Spec->file_name_is_absolute($command) ) {
- return $self->_maybe_command($command);
-
- } else {
- for my $dir ( File::Spec->path ) {
- my $abs = File::Spec->catfile($dir, $command);
- return $abs if $abs = $self->_maybe_command($abs);
- }
- }
-}
-
-# Copied from ExtUtils::MM_Unix::maybe_command
-sub _maybe_command {
- my($self,$file) = @_;
- return $file if -x $file && ! -d $file;
- return;
-}
-
-sub _is_interactive {
- return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe?
-}
-
-# NOTE this is a blocking operation if(-t STDIN)
-sub _is_unattended {
- my $self = shift;
- return $ENV{PERL_MM_USE_DEFAULT} ||
- ( !$self->_is_interactive && eof STDIN );
-}
-
-sub _readline {
- my $self = shift;
- return undef if $self->_is_unattended;
-
- my $answer = <STDIN>;
- chomp $answer if defined $answer;
- return $answer;
-}
-
-sub prompt {
- my $self = shift;
- my $mess = shift
- or die "prompt() called without a prompt message";
-
- # use a list to distinguish a default of undef() from no default
- my @def;
- @def = (shift) if @_;
- # use dispdef for output
- my @dispdef = scalar(@def) ?
- ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') :
- (' ', '');
-
- local $|=1;
- print "$mess ", @dispdef;
-
- if ( $self->_is_unattended && !@def ) {
- die <<EOF;
-ERROR: This build seems to be unattended, but there is no default value
-for this question. Aborting.
-EOF
- }
-
- my $ans = $self->_readline();
-
- if ( !defined($ans) # Ctrl-D or unattended
- or !length($ans) ) { # User hit return
- print "$dispdef[1]\n";
- $ans = scalar(@def) ? $def[0] : '';
- }
-
- return $ans;
-}
-
-sub y_n {
- my $self = shift;
- my ($mess, $def) = @_;
-
- die "y_n() called without a prompt message" unless $mess;
- die "Invalid default value: y_n() default must be 'y' or 'n'"
- if $def && $def !~ /^[yn]/i;
-
- my $answer;
- while (1) { # XXX Infinite or a large number followed by an exception ?
- $answer = $self->prompt(@_);
- return 1 if $answer =~ /^y/i;
- return 0 if $answer =~ /^n/i;
- local $|=1;
- print "Please answer 'y' or 'n'.\n";
- }
-}
-
-sub current_action { shift->{action} }
-sub invoked_action { shift->{invoked_action} }
-
-sub notes { shift()->{phash}{notes}->access(@_) }
-sub config_data { shift()->{phash}{config_data}->access(@_) }
-sub runtime_params { shift->{phash}{runtime_params}->read( @_ ? shift : () ) } # Read-only
-sub auto_features { shift()->{phash}{auto_features}->access(@_) }
-
-sub features {
- my $self = shift;
- my $ph = $self->{phash};
-
- if (@_) {
- my $key = shift;
- if ($ph->{features}->exists($key)) {
- return $ph->{features}->access($key, @_);
- }
-
- if (my $info = $ph->{auto_features}->access($key)) {
- my $disabled;
- for my $type ( @{$self->prereq_action_types} ) {
- next if $type eq 'description' || $type eq 'recommends' || ! exists $info->{$type};
- my $prereqs = $info->{$type};
- for my $modname ( sort keys %$prereqs ) {
- my $spec = $prereqs->{$modname};
- my $status = $self->check_installed_status($modname, $spec);
- if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
- if ( ! eval "require $modname; 1" ) { return 0; }
- }
- }
- return 1;
- }
-
- return $ph->{features}->access($key, @_);
- }
-
- # No args - get the auto_features & overlay the regular features
- my %features;
- my %auto_features = $ph->{auto_features}->access();
- while (my ($name, $info) = each %auto_features) {
- my $failures = $self->prereq_failures($info);
- my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
- keys %$failures ) ? 1 : 0;
- $features{$name} = $disabled ? 0 : 1;
- }
- %features = (%features, $ph->{features}->access());
-
- return wantarray ? %features : \%features;
-}
-BEGIN { *feature = \&features } # Alias
-
-sub _mb_feature {
- my $self = shift;
-
- if (($self->module_name || '') eq 'Module::Build') {
- # We're building Module::Build itself, so ...::ConfigData isn't
- # valid, but $self->features() should be.
- return $self->feature(@_);
- } else {
- require Module::Build::ConfigData;
- return Module::Build::ConfigData->feature(@_);
- }
-}
-
-sub _warn_mb_feature_deps {
- my $self = shift;
- my $name = shift;
- $self->log_warn(
- "The '$name' feature is not available. Please install missing\n" .
- "feature dependencies and try again.\n".
- $self->_feature_deps_msg($name) . "\n"
- );
-}
-
-sub add_build_element {
- my ($self, $elem) = @_;
- my $elems = $self->build_elements;
- push @$elems, $elem unless grep { $_ eq $elem } @$elems;
-}
-
-sub ACTION_config_data {
- my $self = shift;
- return unless $self->has_config_data;
-
- my $module_name = $self->module_name
- or die "The config_data feature requires that 'module_name' be set";
- my $notes_name = $module_name . '::ConfigData'; # TODO: Customize name ???
- my $notes_pm = File::Spec->catfile($self->blib, 'lib', split /::/, "$notes_name.pm");
-
- return if $self->up_to_date(['Build.PL',
- $self->config_file('config_data'),
- $self->config_file('features')
- ], $notes_pm);
-
- $self->log_verbose("Writing config notes to $notes_pm\n");
- File::Path::mkpath(File::Basename::dirname($notes_pm));
-
- Module::Build::Notes->write_config_data
- (
- file => $notes_pm,
- module => $module_name,
- config_module => $notes_name,
- config_data => scalar $self->config_data,
- feature => scalar $self->{phash}{features}->access(),
- auto_features => scalar $self->auto_features,
- );
-}
-
-########################################################################
-{ # enclosing these lexicals -- TODO
- my %valid_properties = ( __PACKAGE__, {} );
- my %additive_properties;
-
- sub _mb_classes {
- my $class = ref($_[0]) || $_[0];
- return ($class, $class->mb_parents);
- }
-
- sub valid_property {
- my ($class, $prop) = @_;
- return grep exists( $valid_properties{$_}{$prop} ), $class->_mb_classes;
- }
-
- sub valid_properties {
- return keys %{ shift->valid_properties_defaults() };
- }
-
- sub valid_properties_defaults {
- my %out;
- for my $class (reverse shift->_mb_classes) {
- @out{ keys %{ $valid_properties{$class} } } = map {
- $_->()
- } values %{ $valid_properties{$class} };
- }
- return \%out;
- }
-
- sub array_properties {
- map { exists $additive_properties{$_}->{ARRAY} ? @{$additive_properties{$_}->{ARRAY}} : () } shift->_mb_classes;
- }
-
- sub hash_properties {
- map { exists $additive_properties{$_}->{HASH} ? @{$additive_properties{$_}->{HASH}} : () } shift->_mb_classes;
- }
-
- sub add_property {
- my ($class, $property) = (shift, shift);
- die "Property '$property' already exists"
- if $class->valid_property($property);
- my %p = @_ == 1 ? ( default => shift ) : @_;
-
- my $type = ref $p{default};
- $valid_properties{$class}{$property} =
- $type eq 'CODE' ? $p{default} :
- $type eq 'HASH' ? sub { return { %{ $p{default} } } } :
- $type eq 'ARRAY'? sub { return [ @{ $p{default} } ] } :
- sub { return $p{default} } ;
-
- push @{$additive_properties{$class}->{$type}}, $property
- if $type;
-
- unless ($class->can($property)) {
- # TODO probably should put these in a util package
- my $sub = $type eq 'HASH'
- ? _make_hash_accessor($property, \%p)
- : _make_accessor($property, \%p);
- no strict 'refs';
- *{"$class\::$property"} = $sub;
- }
-
- return $class;
- }
-
- sub property_error {
- my $self = shift;
- die 'ERROR: ', @_;
- }
-
- sub _set_defaults {
- my $self = shift;
-
- # Set the build class.
- $self->{properties}{build_class} ||= ref $self;
-
- # If there was no orig_dir, set to the same as base_dir
- $self->{properties}{orig_dir} ||= $self->{properties}{base_dir};
-
- my $defaults = $self->valid_properties_defaults;
-
- foreach my $prop (keys %$defaults) {
- $self->{properties}{$prop} = $defaults->{$prop}
- unless exists $self->{properties}{$prop};
- }
-
- # Copy defaults for arrays any arrays.
- for my $prop ($self->array_properties) {
- $self->{properties}{$prop} = [@{$defaults->{$prop}}]
- unless exists $self->{properties}{$prop};
- }
- # Copy defaults for arrays any hashes.
- for my $prop ($self->hash_properties) {
- $self->{properties}{$prop} = {%{$defaults->{$prop}}}
- unless exists $self->{properties}{$prop};
- }
- }
-
-} # end enclosure
-########################################################################
-sub _make_hash_accessor {
- my ($property, $p) = @_;
- my $check = $p->{check} || sub { 1 };
-
- return sub {
- my $self = shift;
-
- # This is only here to deprecate the historic accident of calling
- # properties as class methods - I suspect it only happens in our
- # test suite.
- unless(ref($self)) {
- carp("\n$property not a class method (@_)");
- return;
- }
-
- my $x = $self->{properties};
- return $x->{$property} unless @_;
-
- my $prop = $x->{$property};
- if ( defined $_[0] && !ref $_[0] ) {
- if ( @_ == 1 ) {
- return exists $prop->{$_[0]} ? $prop->{$_[0]} : undef;
- } elsif ( @_ % 2 == 0 ) {
- my %new = (%{ $prop }, @_);
- local $_ = \%new;
- $x->{$property} = \%new if $check->($self);
- return $x->{$property};
- } else {
- die "Unexpected arguments for property '$property'\n";
- }
- } else {
- die "Unexpected arguments for property '$property'\n"
- if defined $_[0] && ref $_[0] ne 'HASH';
- local $_ = $_[0];
- $x->{$property} = shift if $check->($self);
- }
- };
-}
-########################################################################
-sub _make_accessor {
- my ($property, $p) = @_;
- my $check = $p->{check} || sub { 1 };
-
- return sub {
- my $self = shift;
-
- # This is only here to deprecate the historic accident of calling
- # properties as class methods - I suspect it only happens in our
- # test suite.
- unless(ref($self)) {
- carp("\n$property not a class method (@_)");
- return;
- }
-
- my $x = $self->{properties};
- return $x->{$property} unless @_;
- local $_ = $_[0];
- $x->{$property} = shift if $check->($self);
- return $x->{$property};
- };
-}
-########################################################################
-
-# Add the default properties.
-__PACKAGE__->add_property(auto_configure_requires => 1);
-__PACKAGE__->add_property(blib => 'blib');
-__PACKAGE__->add_property(build_class => 'Module::Build');
-__PACKAGE__->add_property(build_elements => [qw(PL support pm xs share_dir pod script)]);
-__PACKAGE__->add_property(build_script => 'Build');
-__PACKAGE__->add_property(build_bat => 0);
-__PACKAGE__->add_property(bundle_inc => []);
-__PACKAGE__->add_property(bundle_inc_preload => []);
-__PACKAGE__->add_property(config_dir => '_build');
-__PACKAGE__->add_property(dynamic_config => 1);
-__PACKAGE__->add_property(include_dirs => []);
-__PACKAGE__->add_property(license => 'unknown');
-__PACKAGE__->add_property(metafile => 'META.yml');
-__PACKAGE__->add_property(mymetafile => 'MYMETA.yml');
-__PACKAGE__->add_property(metafile2 => 'META.json');
-__PACKAGE__->add_property(mymetafile2 => 'MYMETA.json');
-__PACKAGE__->add_property(recurse_into => []);
-__PACKAGE__->add_property(use_rcfile => 1);
-__PACKAGE__->add_property(create_packlist => 1);
-__PACKAGE__->add_property(allow_mb_mismatch => 0);
-__PACKAGE__->add_property(config => undef);
-__PACKAGE__->add_property(test_file_exts => ['.t']);
-__PACKAGE__->add_property(use_tap_harness => 0);
-__PACKAGE__->add_property(cpan_client => 'cpan');
-__PACKAGE__->add_property(tap_harness_args => {});
-__PACKAGE__->add_property(pureperl_only => 0);
-__PACKAGE__->add_property(allow_pureperl => 0);
-__PACKAGE__->add_property(
- 'installdirs',
- default => 'site',
- check => sub {
- return 1 if /^(core|site|vendor)$/;
- return shift->property_error(
- $_ eq 'perl'
- ? 'Perhaps you meant installdirs to be "core" rather than "perl"?'
- : 'installdirs must be one of "core", "site", or "vendor"'
- );
- return shift->property_error("Perhaps you meant 'core'?") if $_ eq 'perl';
- return 0;
- },
-);
-
-{
- __PACKAGE__->add_property(html_css => '');
-}
-
-{
- my @prereq_action_types = qw(requires build_requires test_requires conflicts recommends);
- foreach my $type (@prereq_action_types) {
- __PACKAGE__->add_property($type => {});
- }
- __PACKAGE__->add_property(prereq_action_types => \@prereq_action_types);
-}
-
-__PACKAGE__->add_property($_ => {}) for qw(
- get_options
- install_base_relpaths
- install_path
- install_sets
- meta_add
- meta_merge
- original_prefix
- prefix_relpaths
- configure_requires
-);
-
-__PACKAGE__->add_property($_) for qw(
- PL_files
- autosplit
- base_dir
- bindoc_dirs
- c_source
- create_license
- create_makefile_pl
- create_readme
- debugger
- destdir
- dist_abstract
- dist_author
- dist_name
- dist_suffix
- dist_version
- dist_version_from
- extra_compiler_flags
- extra_linker_flags
- has_config_data
- install_base
- libdoc_dirs
- magic_number
- mb_version
- module_name
- needs_compiler
- orig_dir
- perl
- pm_files
- pod_files
- pollute
- prefix
- program_name
- quiet
- recursive_test_files
- release_status
- script_files
- scripts
- share_dir
- sign
- test_files
- verbose
- debug
- xs_files
- extra_manify_args
-);
-
-sub config {
- my $self = shift;
- my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
- return $c->all_config unless @_;
-
- my $key = shift;
- return $c->get($key) unless @_;
-
- my $val = shift;
- return $c->set($key => $val);
-}
-
-sub mb_parents {
- # Code borrowed from Class::ISA.
- my @in_stack = (shift);
- my %seen = ($in_stack[0] => 1);
-
- my ($current, @out);
- while (@in_stack) {
- next unless defined($current = shift @in_stack)
- && $current->isa('Module::Build::Base');
- push @out, $current;
- next if $current eq 'Module::Build::Base';
- no strict 'refs';
- unshift @in_stack,
- map {
- my $c = $_; # copy, to avoid being destructive
- substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
- # Canonize the :: -> main::, ::foo -> main::foo thing.
- # Should I ever canonize the Foo'Bar = Foo::Bar thing?
- $seen{$c}++ ? () : $c;
- } @{"$current\::ISA"};
-
- # I.e., if this class has any parents (at least, ones I've never seen
- # before), push them, in order, onto the stack of classes I need to
- # explore.
- }
- shift @out;
- return @out;
-}
-
-sub extra_linker_flags { shift->_list_accessor('extra_linker_flags', @_) }
-sub extra_compiler_flags { shift->_list_accessor('extra_compiler_flags', @_) }
-
-sub _list_accessor {
- (my $self, local $_) = (shift, shift);
- my $p = $self->{properties};
- $p->{$_} = [@_] if @_;
- $p->{$_} = [] unless exists $p->{$_};
- return ref($p->{$_}) ? $p->{$_} : [$p->{$_}];
-}
-
-# XXX Problem - if Module::Build is loaded from a different directory,
-# it'll look for (and perhaps destroy/create) a _build directory.
-sub subclass {
- my ($pack, %opts) = @_;
-
- my $build_dir = '_build'; # XXX The _build directory is ostensibly settable by the user. Shouldn't hard-code here.
- $pack->delete_filetree($build_dir) if -e $build_dir;
-
- die "Must provide 'code' or 'class' option to subclass()\n"
- unless $opts{code} or $opts{class};
-
- $opts{code} ||= '';
- $opts{class} ||= 'MyModuleBuilder';
-
- my $filename = File::Spec->catfile($build_dir, 'lib', split '::', $opts{class}) . '.pm';
- my $filedir = File::Basename::dirname($filename);
- $pack->log_verbose("Creating custom builder $filename in $filedir\n");
-
- File::Path::mkpath($filedir);
- die "Can't create directory $filedir: $!" unless -d $filedir;
-
- open(my $fh, '>', $filename) or die "Can't create $filename: $!";
- print $fh <<EOF;
-package $opts{class};
-use $pack;
-\@ISA = qw($pack);
-$opts{code}
-1;
-EOF
- close $fh;
-
- unshift @INC, File::Spec->catdir(File::Spec->rel2abs($build_dir), 'lib');
- eval "use $opts{class}";
- die $@ if $@;
-
- return $opts{class};
-}
-
-sub _guess_module_name {
- my $self = shift;
- my $p = $self->{properties};
- return if $p->{module_name};
- if ( $p->{dist_version_from} && -e $p->{dist_version_from} ) {
- my $mi = Module::Build::ModuleInfo->new_from_file($self->dist_version_from);
- $p->{module_name} = $mi->name;
- }
- else {
- my $mod_path = my $mod_name = $p->{dist_name};
- $mod_name =~ s{-}{::}g;
- $mod_path =~ s{-}{/}g;
- $mod_path .= ".pm";
- if ( -e $mod_path || -e "lib/$mod_path" ) {
- $p->{module_name} = $mod_name;
- }
- else {
- $self->log_warn( << 'END_WARN' );
-No 'module_name' was provided and it could not be inferred
-from other properties. This will prevent a packlist from
-being written for this file. Please set either 'module_name'
-or 'dist_version_from' in Build.PL.
-END_WARN
- }
- }
-}
-
-sub dist_name {
- my $self = shift;
- my $p = $self->{properties};
- my $me = 'dist_name';
- return $p->{$me} if defined $p->{$me};
-
- die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter"
- unless $self->module_name;
-
- ($p->{$me} = $self->module_name) =~ s/::/-/g;
-
- return $p->{$me};
-}
-
-sub release_status {
- my ($self) = @_;
- my $me = 'release_status';
- my $p = $self->{properties};
-
- if ( ! defined $p->{$me} ) {
- $p->{$me} = $self->_is_dev_version ? 'testing' : 'stable';
- }
-
- unless ( $p->{$me} =~ qr/\A(?:stable|testing|unstable)\z/ ) {
- die "Illegal value '$p->{$me}' for $me\n";
- }
-
- if ( $p->{$me} eq 'stable' && $self->_is_dev_version ) {
- my $version = $self->dist_version;
- die "Illegal value '$p->{$me}' with version '$version'\n";
- }
- return $p->{$me};
-}
-
-sub dist_suffix {
- my ($self) = @_;
- my $p = $self->{properties};
- my $me = 'dist_suffix';
-
- return $p->{$me} if defined $p->{$me};
-
- if ( $self->release_status eq 'stable' ) {
- $p->{$me} = "";
- }
- else {
- # non-stable release but non-dev version number needs '-TRIAL' appended
- $p->{$me} = $self->_is_dev_version ? "" : "TRIAL" ;
- }
-
- return $p->{$me};
-}
-
-sub dist_version_from {
- my ($self) = @_;
- my $p = $self->{properties};
- my $me = 'dist_version_from';
-
- if ($self->module_name) {
- $p->{$me} ||=
- join( '/', 'lib', split(/::/, $self->module_name) ) . '.pm';
- }
- return $p->{$me} || undef;
-}
-
-sub dist_version {
- my ($self) = @_;
- my $p = $self->{properties};
- my $me = 'dist_version';
-
- return $p->{$me} if defined $p->{$me};
-
- if ( my $dist_version_from = $self->dist_version_from ) {
- my $version_from = File::Spec->catfile( split( qr{/}, $dist_version_from ) );
- my $pm_info = Module::Build::ModuleInfo->new_from_file( $version_from )
- or die "Can't find file $version_from to determine version";
- #$p->{$me} is undef here
- $p->{$me} = $self->normalize_version( $pm_info->version() );
- unless (defined $p->{$me}) {
- die "Can't determine distribution version from $version_from";
- }
- }
-
- die ("Can't determine distribution version, must supply either 'dist_version',\n".
- "'dist_version_from', or 'module_name' parameter")
- unless defined $p->{$me};
-
- return $p->{$me};
-}
-
-sub _is_dev_version {
- my ($self) = @_;
- my $dist_version = $self->dist_version;
- my $version_obj = eval { Module::Build::Version->new( $dist_version ) };
- # assume it's normal if the version string is fatal -- in this case
- # the author might be doing something weird so should play along and
- # assume they'll specify all necessary behavior
- return $@ ? 0 : $version_obj->is_alpha;
-}
-
-sub dist_author { shift->_pod_parse('author') }
-sub dist_abstract { shift->_pod_parse('abstract') }
-
-sub _pod_parse {
- my ($self, $part) = @_;
- my $p = $self->{properties};
- my $member = "dist_$part";
- return $p->{$member} if defined $p->{$member};
-
- my $docfile = $self->_main_docfile
- or return;
- open(my $fh, '<', $docfile)
- or return;
-
- require Module::Build::PodParser;
- my $parser = Module::Build::PodParser->new(fh => $fh);
- my $method = "get_$part";
- return $p->{$member} = $parser->$method();
-}
-
-sub version_from_file { # Method provided for backwards compatibility
- return Module::Build::ModuleInfo->new_from_file($_[1])->version();
-}
-
-sub find_module_by_name { # Method provided for backwards compatibility
- return Module::Build::ModuleInfo->find_module_by_name(@_[1,2]);
-}
-
-{
- # $unlink_list_for_pid{$$} = [ ... ]
- my %unlink_list_for_pid;
-
- sub _unlink_on_exit {
- my $self = shift;
- for my $f ( @_ ) {
- push @{$unlink_list_for_pid{$$}}, $f if -f $f;
- }
- return 1;
- }
-
- END {
- for my $f ( map glob($_), @{ $unlink_list_for_pid{$$} || [] } ) {
- next unless -e $f;
- File::Path::rmtree($f, 0, 0);
- }
- }
-}
-
-sub add_to_cleanup {
- my $self = shift;
- my %files = map {$self->localize_file_path($_), 1} @_;
- $self->{phash}{cleanup}->write(\%files);
-}
-
-sub cleanup {
- my $self = shift;
- my $all = $self->{phash}{cleanup}->read;
- return keys %$all;
-}
-
-sub config_file {
- my $self = shift;
- return unless -d $self->config_dir;
- return File::Spec->catfile($self->config_dir, @_);
-}
-
-sub read_config {
- my ($self) = @_;
-
- my $file = $self->config_file('build_params')
- or die "Can't find 'build_params' in " . $self->config_dir;
- open(my $fh, '<', $file) or die "Can't read '$file': $!";
- my $ref = eval do {local $/; <$fh>};
- die if $@;
- close $fh;
- my $c;
- ($self->{args}, $c, $self->{properties}) = @$ref;
- $self->{config} = Module::Build::Config->new(values => $c);
-}
-
-sub has_config_data {
- my $self = shift;
- return scalar grep $self->{phash}{$_}->has_data(), qw(config_data features auto_features);
-}
-
-sub _write_data {
- my ($self, $filename, $data) = @_;
-
- my $file = $self->config_file($filename);
- open(my $fh, '>', $file) or die "Can't create '$file': $!";
- unless (ref($data)) { # e.g. magicnum
- print $fh $data;
- return;
- }
-
- print {$fh} Module::Build::Dumper->_data_dump($data);
- close $fh;
-}
-
-sub write_config {
- my ($self) = @_;
-
- File::Path::mkpath($self->{properties}{config_dir});
- -d $self->{properties}{config_dir} or die "Can't mkdir $self->{properties}{config_dir}: $!";
-
- my @items = @{ $self->prereq_action_types };
- $self->_write_data('prereqs', { map { $_, $self->$_() } @items });
- $self->_write_data('build_params', [$self->{args}, $self->{config}->values_set, $self->{properties}]);
-
- # Set a new magic number and write it to a file
- $self->_write_data('magicnum', $self->magic_number(int rand 1_000_000));
-
- $self->{phash}{$_}->write() foreach qw(notes cleanup features auto_features config_data runtime_params);
-}
-
-{
- # packfile map -- keys are guts of regular expressions; If they match,
- # values are module names corresponding to the packlist
- my %packlist_map = (
- '^File::Spec' => 'Cwd',
- '^Devel::AssertOS' => 'Devel::CheckOS',
- );
-
- sub _find_packlist {
- my ($self, $inst, $mod) = @_;
- my $lookup = $mod;
- my $packlist = eval { $inst->packlist($lookup) };
- if ( ! $packlist ) {
- # try from packlist_map
- while ( my ($re, $new_mod) = each %packlist_map ) {
- if ( $mod =~ qr/$re/ ) {
- $lookup = $new_mod;
- $packlist = eval { $inst->packlist($lookup) };
- last;
- }
- }
- }
- return $packlist ? $lookup : undef;
- }
-
- sub set_bundle_inc {
- my $self = shift;
-
- my $bundle_inc = $self->{properties}{bundle_inc};
- my $bundle_inc_preload = $self->{properties}{bundle_inc_preload};
- # We're in author mode if inc::latest is loaded, but not from cwd
- return unless inc::latest->can('loaded_modules');
- require ExtUtils::Installed;
- # ExtUtils::Installed is buggy about finding additions to default @INC
- my $inst = eval { ExtUtils::Installed->new(extra_libs => [@INC]) };
- if ($@) {
- $self->log_warn( << "EUI_ERROR" );
-Bundling in inc/ is disabled because ExtUtils::Installed could not
-create a list of your installed modules. Here is the error:
-$@
-EUI_ERROR
- return;
- }
- my @bundle_list = map { [ $_, 0 ] } inc::latest->loaded_modules;
-
- # XXX TODO: Need to get ordering of prerequisites correct so they are
- # are loaded in the right order. Use an actual tree?!
-
- while( @bundle_list ) {
- my ($mod, $prereq) = @{ shift @bundle_list };
-
- # XXX TODO: Append prereqs to list
- # skip if core or already in bundle or preload lists
- # push @bundle_list, [$_, 1] for prereqs()
-
- # Locate packlist for bundling
- my $lookup = $self->_find_packlist($inst,$mod);
- if ( ! $lookup ) {
- # XXX Really needs a more helpful error message here
- die << "NO_PACKLIST";
-Could not find a packlist for '$mod'. If it's a core module, try
-force installing it from CPAN.
-NO_PACKLIST
- }
- else {
- push @{ $prereq ? $bundle_inc_preload : $bundle_inc }, $lookup;
- }
- }
- } # sub check_bundling
-}
-
-sub check_autofeatures {
- my ($self) = @_;
- my $features = $self->auto_features;
-
- return 1 unless %$features;
-
- # TODO refactor into ::Util
- my $longest = sub {
- my @str = @_ or croak("no strings given");
-
- my @len = map({length($_)} @str);
- my $max = 0;
- my $longest;
- for my $i (0..$#len) {
- ($max, $longest) = ($len[$i], $str[$i]) if($len[$i] > $max);
- }
- return($longest);
- };
- my $max_name_len = length($longest->(keys %$features));
-
- my ($num_disabled, $log_text) = (0, "\nChecking optional features...\n");
- for my $name ( sort keys %$features ) {
- $log_text .= $self->_feature_deps_msg($name, $max_name_len);
- }
-
- $num_disabled = () = $log_text =~ /disabled/g;
-
- # warn user if features disabled
- if ( $num_disabled ) {
- $self->log_warn( $log_text );
- return 0;
- }
- else {
- $self->log_verbose( $log_text );
- return 1;
- }
-}
-
-sub _feature_deps_msg {
- my ($self, $name, $max_name_len) = @_;
- $max_name_len ||= length $name;
- my $features = $self->auto_features;
- my $info = $features->{$name};
- my $feature_text = "$name" . '.' x ($max_name_len - length($name) + 4);
-
- my ($log_text, $disabled) = ('','');
- if ( my $failures = $self->prereq_failures($info) ) {
- $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
- keys %$failures ) ? 1 : 0;
- $feature_text .= $disabled ? "disabled\n" : "enabled\n";
-
- for my $type ( @{ $self->prereq_action_types } ) {
- next unless exists $failures->{$type};
- $feature_text .= " $type:\n";
- my $prereqs = $failures->{$type};
- for my $module ( sort keys %$prereqs ) {
- my $status = $prereqs->{$module};
- my $required =
- ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0;
- my $prefix = ($required) ? '!' : '*';
- $feature_text .= " $prefix $status->{message}\n";
- }
- }
- } else {
- $feature_text .= "enabled\n";
- }
- $log_text .= $feature_text if $disabled || $self->verbose;
- return $log_text;
-}
-
-# Automatically detect configure_requires prereqs
-sub auto_config_requires {
- my ($self) = @_;
- my $p = $self->{properties};
-
- # add current Module::Build to configure_requires if there
- # isn't one already specified (but not ourself, so we're not circular)
- if ( $self->dist_name ne 'Module-Build'
- && $self->auto_configure_requires
- && ! exists $p->{configure_requires}{'Module::Build'}
- ) {
- (my $ver = $VERSION) =~ s/^(\d+\.\d\d).*$/$1/; # last major release only
- $self->log_warn(<<EOM);
-Module::Build was not found in configure_requires! Adding it now
-automatically as: configure_requires => { 'Module::Build' => $ver }
-EOM
- $self->_add_prereq('configure_requires', 'Module::Build', $ver);
- }
-
- # if we're in author mode, add inc::latest modules to
- # configure_requires if not already set. If we're not in author mode
- # then configure_requires will have been satisfied, or we'll just
- # live with what we've bundled
- if ( inc::latest->can('loaded_module') ) {
- for my $mod ( inc::latest->loaded_modules ) {
- next if exists $p->{configure_requires}{$mod};
- $self->_add_prereq('configure_requires', $mod, $mod->VERSION);
- }
- }
-
- return;
-}
-
-# Automatically detect and add prerequisites based on configuration
-sub auto_require {
- my ($self) = @_;
- my $p = $self->{properties};
-
- # If needs_compiler is not explicitly set, automatically set it
- # If set, we need ExtUtils::CBuilder (and a compiler)
- my $xs_files = $self->find_xs_files;
- if ( ! defined $p->{needs_compiler} ) {
- $self->needs_compiler( keys %$xs_files || defined $self->c_source );
- }
- if ($self->needs_compiler) {
- $self->_add_prereq('build_requires', 'ExtUtils::CBuilder', 0);
- if ( ! $self->have_c_compiler ) {
- $self->log_warn(<<'EOM');
-Warning: ExtUtils::CBuilder not installed or no compiler detected
-Proceeding with configuration, but compilation may fail during Build
-
-EOM
- }
- }
-
- # If using share_dir, require File::ShareDir
- if ( $self->share_dir ) {
- $self->_add_prereq( 'requires', 'File::ShareDir', '1.00' );
- }
-
- return;
-}
-
-sub _add_prereq {
- my ($self, $type, $module, $version) = @_;
- my $p = $self->{properties};
- $version = 0 unless defined $version;
- if ( exists $p->{$type}{$module} ) {
- return if $self->compare_versions( $version, '<=', $p->{$type}{$module} );
- }
- $self->log_verbose("Adding to $type\: $module => $version\n");
- $p->{$type}{$module} = $version;
- return 1;
-}
-
-sub prereq_failures {
- my ($self, $info) = @_;
-
- my @types = @{ $self->prereq_action_types };
- $info ||= {map {$_, $self->$_()} @types};
-
- my $out;
-
- foreach my $type (@types) {
- my $prereqs = $info->{$type};
- for my $modname ( keys %$prereqs ) {
- my $spec = $prereqs->{$modname};
- my $status = $self->check_installed_status($modname, $spec);
-
- if ($type =~ /^(?:\w+_)?conflicts$/) {
- next if !$status->{ok};
- $status->{conflicts} = delete $status->{need};
- $status->{message} = "$modname ($status->{have}) conflicts with this distribution";
-
- } elsif ($type =~ /^(?:\w+_)?recommends$/) {
- next if $status->{ok};
- $status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>'
- ? "$modname is not installed"
- : "$modname ($status->{have}) is installed, but we prefer to have $spec");
- } else {
- next if $status->{ok};
- }
-
- $out->{$type}{$modname} = $status;
- }
- }
-
- return $out;
-}
-
-# returns a hash of defined prerequisites; i.e. only prereq types with values
-sub _enum_prereqs {
- my $self = shift;
- my %prereqs;
- foreach my $type ( @{ $self->prereq_action_types } ) {
- if ( $self->can( $type ) ) {
- my $prereq = $self->$type() || {};
- $prereqs{$type} = $prereq if %$prereq;
- }
- }
- return \%prereqs;
-}
-
-sub check_prereq {
- my $self = shift;
-
- # Check to see if there are any prereqs to check
- my $info = $self->_enum_prereqs;
- return 1 unless $info;
-
- my $log_text = "Checking prerequisites...\n";
-
- my $failures = $self->prereq_failures($info);
-
- if ( $failures ) {
- $self->log_warn($log_text);
- for my $type ( @{ $self->prereq_action_types } ) {
- my $prereqs = $failures->{$type};
- $self->log_warn(" ${type}:\n") if keys %$prereqs;
- for my $module ( sort keys %$prereqs ) {
- my $status = $prereqs->{$module};
- my $prefix = ($type =~ /^(?:\w+_)?recommends$/) ? "* " : "! ";
- $self->log_warn(" $prefix $status->{message}\n");
- }
- }
- return 0;
- } else {
- $self->log_verbose($log_text . "Looks good\n\n");
- return 1;
- }
-}
-
-sub perl_version {
- my ($self) = @_;
- # Check the current perl interpreter
- # It's much more convenient to use $] here than $^V, but 'man
- # perlvar' says I'm not supposed to. Bloody tyrant.
- return $^V ? $self->perl_version_to_float(sprintf "%vd", $^V) : $];
-}
-
-sub perl_version_to_float {
- my ($self, $version) = @_;
- return $version if grep( /\./, $version ) < 2;
- $version =~ s/\./../;
- $version =~ s/\.(\d+)/sprintf '%03d', $1/eg;
- return $version;
-}
-
-sub _parse_conditions {
- my ($self, $spec) = @_;
-
- return ">= 0" if not defined $spec;
- if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
- return (">= $spec");
- } else {
- return split /\s*,\s*/, $spec;
- }
-}
-
-sub try_require {
- my ($self, $modname, $spec) = @_;
- my $status = $self->check_installed_status($modname, defined($spec) ? $spec : 0);
- return unless $status->{ok};
- my $path = $modname;
- $path =~ s{::}{/}g;
- $path .= ".pm";
- if ( defined $INC{$path} ) {
- return 1;
- }
- elsif ( exists $INC{$path} ) { # failed before, don't try again
- return;
- }
- else {
- return eval "require $modname";
- }
-}
-
-sub check_installed_status {
- my ($self, $modname, $spec) = @_;
- my %status = (need => $spec);
-
- if ($modname eq 'perl') {
- $status{have} = $self->perl_version;
-
- } elsif (eval { no strict; $status{have} = ${"${modname}::VERSION"} }) {
- # Don't try to load if it's already loaded
-
- } else {
- my $pm_info = Module::Build::ModuleInfo->new_from_module( $modname );
- unless (defined( $pm_info )) {
- @status{ qw(have message) } = ('<none>', "$modname is not installed");
- return \%status;
- }
-
- $status{have} = eval { $pm_info->version() };
- if ($spec and !defined($status{have})) {
- @status{ qw(have message) } = (undef, "Couldn't find a \$VERSION in prerequisite $modname");
- return \%status;
- }
- }
-
- my @conditions = $self->_parse_conditions($spec);
-
- foreach (@conditions) {
- my ($op, $version) = /^\s* (<=?|>=?|==|!=) \s* ([\w.]+) \s*$/x
- or die "Invalid prerequisite condition '$_' for $modname";
-
- $version = $self->perl_version_to_float($version)
- if $modname eq 'perl';
-
- next if $op eq '>=' and !$version; # Module doesn't have to actually define a $VERSION
-
- unless ($self->compare_versions( $status{have}, $op, $version )) {
- $status{message} = "$modname ($status{have}) is installed, but we need version $op $version";
- return \%status;
- }
- }
-
- $status{ok} = 1;
- return \%status;
-}
-
-sub compare_versions {
- my $self = shift;
- my ($v1, $op, $v2) = @_;
- $v1 = Module::Build::Version->new($v1)
- unless UNIVERSAL::isa($v1,'Module::Build::Version');
-
- my $eval_str = "\$v1 $op \$v2";
- my $result = eval $eval_str;
- $self->log_warn("error comparing versions: '$eval_str' $@") if $@;
-
- return $result;
-}
-
-# I wish I could set $! to a string, but I can't, so I use $@
-sub check_installed_version {
- my ($self, $modname, $spec) = @_;
-
- my $status = $self->check_installed_status($modname, $spec);
-
- if ($status->{ok}) {
- return $status->{have} if $status->{have} and "$status->{have}" ne '<none>';
- return '0 but true';
- }
-
- $@ = $status->{message};
- return 0;
-}
-
-sub make_executable {
- # Perl's chmod() is mapped to useful things on various non-Unix
- # platforms, so we use it in the base class even though it looks
- # Unixish.
-
- my $self = shift;
- foreach (@_) {
- my $current_mode = (stat $_)[2];
- chmod $current_mode | oct(111), $_;
- }
-}
-
-sub is_executable {
- # We assume this does the right thing on generic platforms, though
- # we do some other more specific stuff on Unixish platforms.
- my ($self, $file) = @_;
- return -x $file;
-}
-
-sub _startperl { shift()->config('startperl') }
-
-# Return any directories in @INC which are not in the default @INC for
-# this perl. For example, stuff passed in with -I or loaded with "use lib".
-sub _added_to_INC {
- my $self = shift;
-
- my %seen;
- $seen{$_}++ foreach $self->_default_INC;
- return grep !$seen{$_}++, @INC;
-}
-
-# Determine the default @INC for this Perl
-{
- my @default_inc; # Memoize
- sub _default_INC {
- my $self = shift;
- return @default_inc if @default_inc;
-
- local $ENV{PERL5LIB}; # this is not considered part of the default.
-
- my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
-
- my @inc = $self->_backticks($perl, '-le', 'print for @INC');
- chomp @inc;
-
- return @default_inc = @inc;
- }
-}
-
-sub print_build_script {
- my ($self, $fh) = @_;
-
- my $build_package = $self->build_class;
-
- my $closedata="";
-
- my $config_requires;
- if ( -f $self->metafile ) {
- my $meta = eval { $self->read_metafile( $self->metafile ) };
- $config_requires = $meta && $meta->{configure_requires}{'Module::Build'};
- }
- $config_requires ||= 0;
-
- my %q = map {$_, $self->$_()} qw(config_dir base_dir);
-
- $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish;
-
- $q{magic_numfile} = $self->config_file('magicnum');
-
- my @myINC = $self->_added_to_INC;
- for (@myINC, values %q) {
- $_ = File::Spec->canonpath( $_ ) unless $self->is_vmsish;
- s/([\\\'])/\\$1/g;
- }
-
- my $quoted_INC = join ",\n", map " '$_'", @myINC;
- my $shebang = $self->_startperl;
- my $magic_number = $self->magic_number;
-
- print $fh <<EOF;
-$shebang
-
-use strict;
-use Cwd;
-use File::Basename;
-use File::Spec;
-
-sub magic_number_matches {
- return 0 unless -e '$q{magic_numfile}';
- my \$FH;
- open \$FH, '<','$q{magic_numfile}' or return 0;
- my \$filenum = <\$FH>;
- close \$FH;
- return \$filenum == $magic_number;
-}
-
-my \$progname;
-my \$orig_dir;
-BEGIN {
- \$^W = 1; # Use warnings
- \$progname = basename(\$0);
- \$orig_dir = Cwd::cwd();
- my \$base_dir = '$q{base_dir}';
- if (!magic_number_matches()) {
- unless (chdir(\$base_dir)) {
- die ("Couldn't chdir(\$base_dir), aborting\\n");
- }
- unless (magic_number_matches()) {
- die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n");
- }
- }
- unshift \@INC,
- (
-$quoted_INC
- );
-}
-
-close(*DATA) unless eof(*DATA); # ensure no open handles to this script
-
-use $build_package;
-Module::Build->VERSION(q{$config_requires});
-
-# Some platforms have problems setting \$^X in shebang contexts, fix it up here
-\$^X = Module::Build->find_perl_interpreter;
-
-if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) {
- warn "Warning: Build.PL has been altered. You may need to run 'perl Build.PL' again.\\n";
-}
-
-# This should have just enough arguments to be able to bootstrap the rest.
-my \$build = $build_package->resume (
- properties => {
- config_dir => '$q{config_dir}',
- orig_dir => \$orig_dir,
- },
-);
-
-\$build->dispatch;
-EOF
-}
-
-sub create_mymeta {
- my ($self) = @_;
-
- my ($meta_obj, $mymeta);
- my @metafiles = ( $self->metafile2, $self->metafile, );
- my @mymetafiles = ( $self->mymetafile2, $self->mymetafile, );
-
- # cleanup old MYMETA
- for my $f ( @mymetafiles ) {
- if ( $self->delete_filetree($f) ) {
- $self->log_verbose("Removed previous '$f'\n");
- }
- }
-
- # Try loading META.json or META.yml
- if ( $self->try_require("CPAN::Meta", "2.110420") ) {
- for my $file ( @metafiles ) {
- next unless -f $file;
- $meta_obj = eval { CPAN::Meta->load_file($file, { lazy_validation => 0 }) };
- last if $meta_obj;
- }
- }
-
- # maybe get a copy in spec v2 format (regardless of original source)
-
- my $mymeta_obj;
- if ($meta_obj) {
- # if we have metadata, just update it
- my %updated = (
- %{ $meta_obj->as_struct({ version => 2.0 }) },
- prereqs => $self->_normalize_prereqs,
- dynamic_config => 0,
- generated_by => "Module::Build version $Module::Build::VERSION",
- );
- $mymeta_obj = CPAN::Meta->new( \%updated, { lazy_validation => 0 } );
- }
- else {
- $mymeta_obj = $self->_get_meta_object(quiet => 0, dynamic => 0, fatal => 1, auto => 0);
- }
-
- my @created = $self->_write_meta_files( $mymeta_obj, 'MYMETA' );
-
- $self->log_warn("Could not create MYMETA files\n")
- unless @created;
-
- return 1;
-}
-
-sub create_build_script {
- my ($self) = @_;
-
- $self->write_config;
- $self->create_mymeta;
-
- # Create Build
- my ($build_script, $dist_name, $dist_version)
- = map $self->$_(), qw(build_script dist_name dist_version);
-
- if ( $self->delete_filetree($build_script) ) {
- $self->log_verbose("Removed previous script '$build_script'\n");
- }
-
- $self->log_info("Creating new '$build_script' script for ",
- "'$dist_name' version '$dist_version'\n");
- open(my $fh, '>', $build_script) or die "Can't create '$build_script': $!";
- $self->print_build_script($fh);
- close $fh;
-
- $self->make_executable($build_script);
-
- return 1;
-}
-
-sub check_manifest {
- my $self = shift;
- return unless -e 'MANIFEST';
-
- # Stolen nearly verbatim from MakeMaker. But ExtUtils::Manifest
- # could easily be re-written into a modern Perl dialect.
-
- require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean.
- local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
-
- $self->log_verbose("Checking whether your kit is complete...\n");
- if (my @missed = ExtUtils::Manifest::manicheck()) {
- $self->log_warn("WARNING: the following files are missing in your kit:\n",
- "\t", join("\n\t", @missed), "\n",
- "Please inform the author.\n\n");
- } else {
- $self->log_verbose("Looks good\n\n");
- }
-}
-
-sub dispatch {
- my $self = shift;
- local $self->{_completed_actions} = {};
-
- if (@_) {
- my ($action, %p) = @_;
- my $args = $p{args} ? delete($p{args}) : {};
-
- local $self->{invoked_action} = $action;
- local $self->{args} = {%{$self->{args}}, %$args};
- local $self->{properties} = {%{$self->{properties}}, %p};
- return $self->_call_action($action);
- }
-
- die "No build action specified" unless $self->{action};
- local $self->{invoked_action} = $self->{action};
- $self->_call_action($self->{action});
-}
-
-sub _call_action {
- my ($self, $action) = @_;
-
- return if $self->{_completed_actions}{$action}++;
-
- local $self->{action} = $action;
- my $method = $self->can_action( $action );
- die "No action '$action' defined, try running the 'help' action.\n" unless $method;
- $self->log_debug("Starting ACTION_$action\n");
- my $rc = $self->$method();
- $self->log_debug("Finished ACTION_$action\n");
- return $rc;
-}
-
-sub can_action {
- my ($self, $action) = @_;
- return $self->can( "ACTION_$action" );
-}
-
-# cuts the user-specified options out of the command-line args
-sub cull_options {
- my $self = shift;
- my (@argv) = @_;
-
- # XXX is it even valid to call this as a class method?
- return({}, @argv) unless(ref($self)); # no object
-
- my $specs = $self->get_options;
- return({}, @argv) unless($specs and %$specs); # no user options
-
- require Getopt::Long;
- # XXX Should we let Getopt::Long handle M::B's options? That would
- # be easy-ish to add to @specs right here, but wouldn't handle options
- # passed without "--" as M::B currently allows. We might be able to
- # get around this by setting the "prefix_pattern" Configure option.
- my @specs;
- my $args = {};
- # Construct the specifications for GetOptions.
- while (my ($k, $v) = each %$specs) {
- # Throw an error if specs conflict with our own.
- die "Option specification '$k' conflicts with a " . ref $self
- . " option of the same name"
- if $self->valid_property($k);
- push @specs, $k . (defined $v->{type} ? $v->{type} : '');
- push @specs, $v->{store} if exists $v->{store};
- $args->{$k} = $v->{default} if exists $v->{default};
- }
-
- local @ARGV = @argv; # No other way to dupe Getopt::Long
-
- # Get the options values and return them.
- # XXX Add option to allow users to set options?
- if ( @specs ) {
- Getopt::Long::Configure('pass_through');
- Getopt::Long::GetOptions($args, @specs);
- }
-
- return $args, @ARGV;
-}
-
-sub unparse_args {
- my ($self, $args) = @_;
- my @out;
- while (my ($k, $v) = each %$args) {
- push @out, (UNIVERSAL::isa($v, 'HASH') ? map {+"--$k", "$_=$v->{$_}"} keys %$v :
- UNIVERSAL::isa($v, 'ARRAY') ? map {+"--$k", $_} @$v :
- ("--$k", $v));
- }
- return @out;
-}
-
-sub args {
- my $self = shift;
- return wantarray ? %{ $self->{args} } : $self->{args} unless @_;
- my $key = shift;
- $self->{args}{$key} = shift if @_;
- return $self->{args}{$key};
-}
-
-# allows select parameters (with underscores) to be spoken with dashes
-# when used as command-line options
-sub _translate_option {
- my $self = shift;
- my $opt = shift;
-
- (my $tr_opt = $opt) =~ tr/-/_/;
-
- return $tr_opt if grep $tr_opt =~ /^(?:no_?)?$_$/, qw(
- create_license
- create_makefile_pl
- create_readme
- extra_compiler_flags
- extra_linker_flags
- install_base
- install_path
- meta_add
- meta_merge
- test_files
- use_rcfile
- use_tap_harness
- tap_harness_args
- cpan_client
- pureperl_only
- allow_pureperl
- ); # normalize only selected option names
-
- return $opt;
-}
-
-my %singular_argument = map { ($_ => 1) } qw/install_base prefix destdir installdir verbose quiet uninst debug sign/;
-
-sub _read_arg {
- my ($self, $args, $key, $val) = @_;
-
- $key = $self->_translate_option($key);
-
- if ( exists $args->{$key} and not $singular_argument{$key} ) {
- $args->{$key} = [ $args->{$key} ] unless ref $args->{$key};
- push @{$args->{$key}}, $val;
- } else {
- $args->{$key} = $val;
- }
-}
-
-# decide whether or not an option requires/has an operand
-sub _optional_arg {
- my $self = shift;
- my $opt = shift;
- my $argv = shift;
-
- $opt = $self->_translate_option($opt);
-
- my @bool_opts = qw(
- build_bat
- create_license
- create_readme
- pollute
- quiet
- uninst
- use_rcfile
- verbose
- debug
- sign
- use_tap_harness
- pureperl_only
- allow_pureperl
- );
-
- # inverted boolean options; eg --noverbose or --no-verbose
- # converted to proper name & returned with false value (verbose, 0)
- if ( grep $opt =~ /^no[-_]?$_$/, @bool_opts ) {
- $opt =~ s/^no-?//;
- return ($opt, 0);
- }
-
- # non-boolean option; return option unchanged along with its argument
- return ($opt, shift(@$argv)) unless grep $_ eq $opt, @bool_opts;
-
- # we're punting a bit here, if an option appears followed by a digit
- # we take the digit as the argument for the option. If there is
- # nothing that looks like a digit, we pretend the option is a flag
- # that is being set and has no argument.
- my $arg = 1;
- $arg = shift(@$argv) if @$argv && $argv->[0] =~ /^\d+$/;
-
- return ($opt, $arg);
-}
-
-sub read_args {
- my $self = shift;
-
- (my $args, @_) = $self->cull_options(@_);
- my %args = %$args;
-
- my $opt_re = qr/[\w\-]+/;
-
- my ($action, @argv);
- while (@_) {
- local $_ = shift;
- if ( /^(?:--)?($opt_re)=(.*)$/ ) {
- $self->_read_arg(\%args, $1, $2);
- } elsif ( /^--($opt_re)$/ ) {
- my($opt, $arg) = $self->_optional_arg($1, \@_);
- $self->_read_arg(\%args, $opt, $arg);
- } elsif ( /^($opt_re)$/ and !defined($action)) {
- $action = $1;
- } else {
- push @argv, $_;
- }
- }
- $args{ARGV} = \@argv;
-
- for ('extra_compiler_flags', 'extra_linker_flags') {
- $args{$_} = [ $self->split_like_shell($args{$_}) ] if exists $args{$_};
- }
-
- # Convert to arrays
- for ('include_dirs') {
- $args{$_} = [ $args{$_} ] if exists $args{$_} && !ref $args{$_}
- }
-
- # Hashify these parameters
- for ($self->hash_properties, 'config') {
- next unless exists $args{$_};
- my %hash;
- $args{$_} ||= [];
- $args{$_} = [ $args{$_} ] unless ref $args{$_};
- foreach my $arg ( @{$args{$_}} ) {
- $arg =~ /($opt_re)=(.*)/
- or die "Malformed '$_' argument: '$arg' should be something like 'foo=bar'";
- $hash{$1} = $2;
- }
- $args{$_} = \%hash;
- }
-
- # De-tilde-ify any path parameters
- for my $key (qw(prefix install_base destdir)) {
- next if !defined $args{$key};
- $args{$key} = $self->_detildefy($args{$key});
- }
-
- for my $key (qw(install_path)) {
- next if !defined $args{$key};
-
- for my $subkey (keys %{$args{$key}}) {
- next if !defined $args{$key}{$subkey};
- my $subkey_ext = $self->_detildefy($args{$key}{$subkey});
- if ( $subkey eq 'html' ) { # translate for compatibility
- $args{$key}{binhtml} = $subkey_ext;
- $args{$key}{libhtml} = $subkey_ext;
- } else {
- $args{$key}{$subkey} = $subkey_ext;
- }
- }
- }
-
- if ($args{makefile_env_macros}) {
- require Module::Build::Compat;
- %args = (%args, Module::Build::Compat->makefile_to_build_macros);
- }
-
- return \%args, $action;
-}
-
-# Default: do nothing. Overridden for Unix & Windows.
-sub _detildefy {}
-
-
-# merge Module::Build argument lists that have already been parsed
-# by read_args(). Takes two references to option hashes and merges
-# the contents, giving priority to the first.
-sub _merge_arglist {
- my( $self, $opts1, $opts2 ) = @_;
-
- $opts1 ||= {};
- $opts2 ||= {};
- my %new_opts = %$opts1;
- while (my ($key, $val) = each %$opts2) {
- if ( exists( $opts1->{$key} ) ) {
- if ( ref( $val ) eq 'HASH' ) {
- while (my ($k, $v) = each %$val) {
- $new_opts{$key}{$k} = $v unless exists( $opts1->{$key}{$k} );
- }
- }
- } else {
- $new_opts{$key} = $val
- }
- }
-
- return %new_opts;
-}
-
-# Look for a home directory on various systems.
-sub _home_dir {
- my @home_dirs;
- push( @home_dirs, $ENV{HOME} ) if $ENV{HOME};
-
- push( @home_dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
- if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
-
- my @other_home_envs = qw( USERPROFILE APPDATA WINDIR SYS$LOGIN );
- push( @home_dirs, map $ENV{$_}, grep $ENV{$_}, @other_home_envs );
-
- my @real_home_dirs = grep -d, @home_dirs;
-
- return wantarray ? @real_home_dirs : shift( @real_home_dirs );
-}
-
-sub _find_user_config {
- my $self = shift;
- my $file = shift;
- foreach my $dir ( $self->_home_dir ) {
- my $path = File::Spec->catfile( $dir, $file );
- return $path if -e $path;
- }
- return undef;
-}
-
-# read ~/.modulebuildrc returning global options '*' and
-# options specific to the currently executing $action.
-sub read_modulebuildrc {
- my( $self, $action ) = @_;
-
- return () unless $self->use_rcfile;
-
- my $modulebuildrc;
- if ( exists($ENV{MODULEBUILDRC}) && $ENV{MODULEBUILDRC} eq 'NONE' ) {
- return ();
- } elsif ( exists($ENV{MODULEBUILDRC}) && -e $ENV{MODULEBUILDRC} ) {
- $modulebuildrc = $ENV{MODULEBUILDRC};
- } elsif ( exists($ENV{MODULEBUILDRC}) ) {
- $self->log_warn("WARNING: Can't find resource file " .
- "'$ENV{MODULEBUILDRC}' defined in environment.\n" .
- "No options loaded\n");
- return ();
- } else {
- $modulebuildrc = $self->_find_user_config( '.modulebuildrc' );
- return () unless $modulebuildrc;
- }
-
- open(my $fh, '<', $modulebuildrc )
- or die "Can't open $modulebuildrc: $!";
-
- my %options; my $buffer = '';
- while (defined( my $line = <$fh> )) {
- chomp( $line );
- $line =~ s/#.*$//;
- next unless length( $line );
-
- if ( $line =~ /^\S/ ) {
- if ( $buffer ) {
- my( $action, $options ) = split( /\s+/, $buffer, 2 );
- $options{$action} .= $options . ' ';
- $buffer = '';
- }
- $buffer = $line;
- } else {
- $buffer .= $line;
- }
- }
-
- if ( $buffer ) { # anything left in $buffer ?
- my( $action, $options ) = split( /\s+/, $buffer, 2 );
- $options{$action} .= $options . ' '; # merge if more than one line
- }
-
- my ($global_opts) =
- $self->read_args( $self->split_like_shell( $options{'*'} || '' ) );
-
- # let fakeinstall act like install if not provided
- if ( $action eq 'fakeinstall' && ! exists $options{fakeinstall} ) {
- $action = 'install';
- }
- my ($action_opts) =
- $self->read_args( $self->split_like_shell( $options{$action} || '' ) );
-
- # specific $action options take priority over global options '*'
- return $self->_merge_arglist( $action_opts, $global_opts );
-}
-
-# merge the relevant options in ~/.modulebuildrc into Module::Build's
-# option list where they do not conflict with commandline options.
-sub merge_modulebuildrc {
- my( $self, $action, %cmdline_opts ) = @_;
- my %rc_opts = $self->read_modulebuildrc( $action || $self->{action} || 'build' );
- my %new_opts = $self->_merge_arglist( \%cmdline_opts, \%rc_opts );
- $self->merge_args( $action, %new_opts );
-}
-
-sub merge_args {
- my ($self, $action, %args) = @_;
- $self->{action} = $action if defined $action;
-
- my %additive = map { $_ => 1 } $self->hash_properties;
-
- # Extract our 'properties' from $cmd_args, the rest are put in 'args'.
- while (my ($key, $val) = each %args) {
- $self->{phash}{runtime_params}->access( $key => $val )
- if $self->valid_property($key);
-
- if ($key eq 'config') {
- $self->config($_ => $val->{$_}) foreach keys %$val;
- } else {
- my $add_to = $additive{$key} ? $self->{properties}{$key} :
- $self->valid_property($key) ? $self->{properties} :
- $self->{args} ;
-
- if ($additive{$key}) {
- $add_to->{$_} = $val->{$_} foreach keys %$val;
- } else {
- $add_to->{$key} = $val;
- }
- }
- }
-}
-
-sub cull_args {
- my $self = shift;
- my @arg_list = @_;
- unshift @arg_list, $self->split_like_shell($ENV{PERL_MB_OPT})
- if $ENV{PERL_MB_OPT};
- my ($args, $action) = $self->read_args(@arg_list);
- $self->merge_args($action, %$args);
- $self->merge_modulebuildrc( $action, %$args );
-}
-
-sub super_classes {
- my ($self, $class, $seen) = @_;
- $class ||= ref($self) || $self;
- $seen ||= {};
-
- no strict 'refs';
- my @super = grep {not $seen->{$_}++} $class, @{ $class . '::ISA' };
- return @super, map {$self->super_classes($_,$seen)} @super;
-}
-
-sub known_actions {
- my ($self) = @_;
-
- my %actions;
- no strict 'refs';
-
- foreach my $class ($self->super_classes) {
- foreach ( keys %{ $class . '::' } ) {
- $actions{$1}++ if /^ACTION_(\w+)/;
- }
- }
-
- return wantarray ? sort keys %actions : \%actions;
-}
-
-sub get_action_docs {
- my ($self, $action) = @_;
- my $actions = $self->known_actions;
- die "No known action '$action'" unless $actions->{$action};
-
- my ($files_found, @docs) = (0);
- foreach my $class ($self->super_classes) {
- (my $file = $class) =~ s{::}{/}g;
- # NOTE: silently skipping relative paths if any chdir() happened
- $file = $INC{$file . '.pm'} or next;
- open(my $fh, '<', $file) or next;
- $files_found++;
-
- # Code below modified from /usr/bin/perldoc
-
- # Skip to ACTIONS section
- local $_;
- while (<$fh>) {
- last if /^=head1 ACTIONS\s/;
- }
-
- # Look for our action and determine the style
- my $style;
- while (<$fh>) {
- last if /^=head1 /;
-
- # only item and head2 are allowed (3&4 are not in 5.005)
- if(/^=(item|head2)\s+\Q$action\E\b/) {
- $style = $1;
- push @docs, $_;
- last;
- }
- }
- $style or next; # not here
-
- # and the content
- if($style eq 'item') {
- my ($found, $inlist) = (0, 0);
- while (<$fh>) {
- if (/^=(item|back)/) {
- last unless $inlist;
- }
- push @docs, $_;
- ++$inlist if /^=over/;
- --$inlist if /^=back/;
- }
- }
- else { # head2 style
- # stop at anything equal or greater than the found level
- while (<$fh>) {
- last if(/^=(?:head[12]|cut)/);
- push @docs, $_;
- }
- }
- # TODO maybe disallow overriding just pod for an action
- # TODO and possibly: @docs and last;
- }
-
- unless ($files_found) {
- $@ = "Couldn't find any documentation to search";
- return;
- }
- unless (@docs) {
- $@ = "Couldn't find any docs for action '$action'";
- return;
- }
-
- return join '', @docs;
-}
-
-sub ACTION_prereq_report {
- my $self = shift;
- $self->log_info( $self->prereq_report );
-}
-
-sub ACTION_prereq_data {
- my $self = shift;
- $self->log_info( Module::Build::Dumper->_data_dump( $self->prereq_data ) );
-}
-
-sub prereq_data {
- my $self = shift;
- my @types = ('configure_requires', @{ $self->prereq_action_types } );
- my $info = { map { $_ => $self->$_() } grep { %{$self->$_()} } @types };
- return $info;
-}
-
-sub prereq_report {
- my $self = shift;
- my $info = $self->prereq_data;
-
- my $output = '';
- foreach my $type (keys %$info) {
- my $prereqs = $info->{$type};
- $output .= "\n$type:\n";
- my $mod_len = 2;
- my $ver_len = 4;
- my %mods;
- while ( my ($modname, $spec) = each %$prereqs ) {
- my $len = length $modname;
- $mod_len = $len if $len > $mod_len;
- $spec ||= '0';
- $len = length $spec;
- $ver_len = $len if $len > $ver_len;
-
- my $mod = $self->check_installed_status($modname, $spec);
- $mod->{name} = $modname;
- $mod->{ok} ||= 0;
- $mod->{ok} = ! $mod->{ok} if $type =~ /^(\w+_)?conflicts$/;
-
- $mods{lc $modname} = $mod;
- }
-
- my $space = q{ } x ($mod_len - 3);
- my $vspace = q{ } x ($ver_len - 3);
- my $sline = q{-} x ($mod_len - 3);
- my $vline = q{-} x ($ver_len - 3);
- my $disposition = ($type =~ /^(\w+_)?conflicts$/) ?
- 'Clash' : 'Need';
- $output .=
- " Module $space $disposition $vspace Have\n".
- " ------$sline+------$vline-+----------\n";
-
-
- for my $k (sort keys %mods) {
- my $mod = $mods{$k};
- my $space = q{ } x ($mod_len - length $k);
- my $vspace = q{ } x ($ver_len - length $mod->{need});
- my $f = $mod->{ok} ? ' ' : '!';
- $output .=
- " $f $mod->{name} $space $mod->{need} $vspace ".
- (defined($mod->{have}) ? $mod->{have} : "")."\n";
- }
- }
- return $output;
-}
-
-sub ACTION_help {
- my ($self) = @_;
- my $actions = $self->known_actions;
-
- if (@{$self->{args}{ARGV}}) {
- my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)};
- print $@ ? "$@\n" : $msg;
- return;
- }
-
- print <<EOF;
-
- Usage: $0 <action> --arg1=value --arg2=value ...
- Example: $0 test --verbose=1
-
- Actions defined:
-EOF
-
- print $self->_action_listing($actions);
-
- print "\nRun `Build help <action>` for details on an individual action.\n";
- print "See `perldoc Module::Build` for complete documentation.\n";
-}
-
-sub _action_listing {
- my ($self, $actions) = @_;
-
- # Flow down columns, not across rows
- my @actions = sort keys %$actions;
- @actions = map $actions[($_ + ($_ % 2) * @actions) / 2], 0..$#actions;
-
- my $out = '';
- while (my ($one, $two) = splice @actions, 0, 2) {
- $out .= sprintf(" %-12s %-12s\n", $one, $two||'');
- }
- $out =~ s{\s*$}{}mg; # remove trailing spaces
- return $out;
-}
-
-sub ACTION_retest {
- my ($self) = @_;
-
- # Protect others against our @INC changes
- local @INC = @INC;
-
- # Filter out nonsensical @INC entries - some versions of
- # Test::Harness will really explode the number of entries here
- @INC = grep {ref() || -d} @INC if @INC > 100;
-
- $self->do_tests;
-}
-
-sub ACTION_testall {
- my ($self) = @_;
-
- my @types;
- for my $action (grep { $_ ne 'all' } $self->get_test_types) {
- # XXX We can't just dispatch because we get multiple summaries but
- # we'll need to dispatch to support custom setup/teardown in the
- # action. To support that, we'll need to call something besides
- # Harness::runtests() because we'll need to collect the results in
- # parts, then run the summary.
- push(@types, $action);
- #$self->_call_action( "test$action" );
- }
- $self->generic_test(types => ['default', @types]);
-}
-
-sub get_test_types {
- my ($self) = @_;
-
- my $t = $self->{properties}->{test_types};
- return ( defined $t ? ( keys %$t ) : () );
-}
-
-
-sub ACTION_test {
- my ($self) = @_;
- $self->generic_test(type => 'default');
-}
-
-sub generic_test {
- my $self = shift;
- (@_ % 2) and croak('Odd number of elements in argument hash');
- my %args = @_;
-
- my $p = $self->{properties};
-
- my @types = (
- (exists($args{type}) ? $args{type} : ()),
- (exists($args{types}) ? @{$args{types}} : ()),
- );
- @types or croak "need some types of tests to check";
-
- my %test_types = (
- default => $p->{test_file_exts},
- (defined($p->{test_types}) ? %{$p->{test_types}} : ()),
- );
-
- for my $type (@types) {
- croak "$type not defined in test_types!"
- unless defined $test_types{ $type };
- }
-
- # we use local here because it ends up two method calls deep
- local $p->{test_file_exts} = [ map { ref $_ ? @$_ : $_ } @test_types{@types} ];
- $self->depends_on('code');
-
- # Protect others against our @INC changes
- local @INC = @INC;
-
- # Make sure we test the module in blib/
- unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
- File::Spec->catdir($p->{base_dir}, $self->blib, 'arch'));
-
- # Filter out nonsensical @INC entries - some versions of
- # Test::Harness will really explode the number of entries here
- @INC = grep {ref() || -d} @INC if @INC > 100;
-
- $self->do_tests;
-}
-
-# Test::Harness dies on failure but TAP::Harness does not, so we must
-# die if running under TAP::Harness
-sub do_tests {
- my $self = shift;
-
- my $tests = $self->find_test_files;
-
- local $ENV{PERL_DL_NONLAZY} = 1;
-
- if(@$tests) {
- my $args = $self->tap_harness_args;
- if($self->use_tap_harness or ($args and %$args)) {
- my $aggregate = $self->run_tap_harness($tests);
- if ( $aggregate->has_errors ) {
- die "Errors in testing. Cannot continue.\n";
- }
- }
- else {
- $self->run_test_harness($tests);
- }
- }
- else {
- $self->log_info("No tests defined.\n");
- }
-
- $self->run_visual_script;
-}
-
-sub run_tap_harness {
- my ($self, $tests) = @_;
-
- require TAP::Harness;
-
- # TODO allow the test @INC to be set via our API?
-
- my $aggregate = TAP::Harness->new({
- lib => [@INC],
- verbosity => $self->{properties}{verbose},
- switches => [ $self->harness_switches ],
- %{ $self->tap_harness_args },
- })->runtests(@$tests);
-
- return $aggregate;
-}
-
-sub run_test_harness {
- my ($self, $tests) = @_;
- require Test::Harness;
-
- local $Test::Harness::verbose = $self->verbose || 0;
- local $Test::Harness::switches = join ' ', $self->harness_switches;
-
- Test::Harness::runtests(@$tests);
-}
-
-sub run_visual_script {
- my $self = shift;
- # This will get run and the user will see the output. It doesn't
- # emit Test::Harness-style output.
- $self->run_perl_script('visual.pl', '-Mblib='.$self->blib)
- if -e 'visual.pl';
-}
-
-sub harness_switches {
- shift->{properties}{debugger} ? qw(-w -d) : ();
-}
-
-sub test_files {
- my $self = shift;
- my $p = $self->{properties};
- if (@_) {
- return $p->{test_files} = (@_ == 1 ? shift : [@_]);
- }
- return $self->find_test_files;
-}
-
-sub expand_test_dir {
- my ($self, $dir) = @_;
- my $exts = $self->{properties}{test_file_exts};
-
- return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts
- if $self->recursive_test_files;
-
- return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts;
-}
-
-sub ACTION_testdb {
- my ($self) = @_;
- local $self->{properties}{debugger} = 1;
- $self->depends_on('test');
-}
-
-sub ACTION_testcover {
- my ($self) = @_;
-
- unless (Module::Build::ModuleInfo->find_module_by_name('Devel::Cover')) {
- warn("Cannot run testcover action unless Devel::Cover is installed.\n");
- return;
- }
-
- $self->add_to_cleanup('coverage', 'cover_db');
- $self->depends_on('code');
-
- # See whether any of the *.pm files have changed since last time
- # testcover was run. If so, start over.
- if (-e 'cover_db') {
- my $pm_files = $self->rscan_dir
- (File::Spec->catdir($self->blib, 'lib'), $self->file_qr('\.pm$') );
- my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/});
-
- $self->do_system(qw(cover -delete))
- unless $self->up_to_date($pm_files, $cover_files)
- && $self->up_to_date($self->test_files, $cover_files);
- }
-
- local $Test::Harness::switches =
- local $Test::Harness::Switches =
- local $ENV{HARNESS_PERL_SWITCHES} = "-MDevel::Cover";
-
- $self->depends_on('test');
- $self->do_system('cover');
-}
-
-sub ACTION_code {
- my ($self) = @_;
-
- # All installable stuff gets created in blib/ .
- # Create blib/arch to keep blib.pm happy
- my $blib = $self->blib;
- $self->add_to_cleanup($blib);
- File::Path::mkpath( File::Spec->catdir($blib, 'arch') );
-
- if (my $split = $self->autosplit) {
- $self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split);
- }
-
- foreach my $element (@{$self->build_elements}) {
- my $method = "process_${element}_files";
- $method = "process_files_by_extension" unless $self->can($method);
- $self->$method($element);
- }
-
- $self->depends_on('config_data');
-}
-
-sub ACTION_build {
- my $self = shift;
- $self->log_info("Building " . $self->dist_name . "\n");
- $self->depends_on('code');
- $self->depends_on('docs');
-}
-
-sub process_files_by_extension {
- my ($self, $ext) = @_;
-
- my $method = "find_${ext}_files";
- my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext, 'lib');
-
- while (my ($file, $dest) = each %$files) {
- $self->copy_if_modified(from => $file, to => File::Spec->catfile($self->blib, $dest) );
- }
-}
-
-sub process_support_files {
- my $self = shift;
- my $p = $self->{properties};
- return unless $p->{c_source};
-
- my $files;
- if (ref($p->{c_source}) eq "ARRAY") {
- push @{$p->{include_dirs}}, @{$p->{c_source}};
- for my $path (@{$p->{c_source}}) {
- push @$files, @{ $self->rscan_dir($path, $self->file_qr('\.c(c|p|pp|xx|\+\+)?$')) };
- }
- } else {
- push @{$p->{include_dirs}}, $p->{c_source};
- $files = $self->rscan_dir($p->{c_source}, $self->file_qr('\.c(c|p|pp|xx|\+\+)?$'));
- }
-
- foreach my $file (@$files) {
- push @{$p->{objects}}, $self->compile_c($file);
- }
-}
-
-sub process_share_dir_files {
- my $self = shift;
- my $files = $self->_find_share_dir_files;
- return unless $files;
-
- # root for all File::ShareDir paths
- my $share_prefix = File::Spec->catdir($self->blib, qw/lib auto share/);
-
- # copy all share files to blib
- while (my ($file, $dest) = each %$files) {
- $self->copy_if_modified(
- from => $file, to => File::Spec->catfile( $share_prefix, $dest )
- );
- }
-}
-
-sub _find_share_dir_files {
- my $self = shift;
- my $share_dir = $self->share_dir;
- return unless $share_dir;
-
- my @file_map;
- if ( $share_dir->{dist} ) {
- my $prefix = "dist/".$self->dist_name;
- push @file_map, $self->_share_dir_map( $prefix, $share_dir->{dist} );
- }
-
- if ( $share_dir->{module} ) {
- for my $mod ( keys %{ $share_dir->{module} } ) {
- (my $altmod = $mod) =~ s{::}{-}g;
- my $prefix = "module/$altmod";
- push @file_map, $self->_share_dir_map($prefix, $share_dir->{module}{$mod});
- }
- }
-
- return { @file_map };
-}
-
-sub _share_dir_map {
- my ($self, $prefix, $list) = @_;
- my %files;
- for my $dir ( @$list ) {
- for my $f ( @{ $self->rscan_dir( $dir, sub {-f} )} ) {
- $f =~ s{\A.*?\Q$dir\E/}{};
- $files{"$dir/$f"} = "$prefix/$f";
- }
- }
- return %files;
-}
-
-sub process_PL_files {
- my ($self) = @_;
- my $files = $self->find_PL_files;
-
- while (my ($file, $to) = each %$files) {
- unless ($self->up_to_date( $file, $to )) {
- $self->run_perl_script($file, [], [@$to]) or die "$file failed";
- $self->add_to_cleanup(@$to);
- }
- }
-}
-
-sub process_xs_files {
- my $self = shift;
- return if $self->pureperl_only && $self->allow_pureperl;
- my $files = $self->find_xs_files;
- croak 'Can\'t build xs files under --pureperl-only' if %$files && $self->pureperl_only;
- while (my ($from, $to) = each %$files) {
- unless ($from eq $to) {
- $self->add_to_cleanup($to);
- $self->copy_if_modified( from => $from, to => $to );
- }
- $self->process_xs($to);
- }
-}
-
-sub process_pod_files { shift()->process_files_by_extension(shift()) }
-sub process_pm_files { shift()->process_files_by_extension(shift()) }
-
-sub process_script_files {
- my $self = shift;
- my $files = $self->find_script_files;
- return unless keys %$files;
-
- my $script_dir = File::Spec->catdir($self->blib, 'script');
- File::Path::mkpath( $script_dir );
-
- foreach my $file (keys %$files) {
- my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
- $self->fix_shebang_line($result) unless $self->is_vmsish;
- $self->make_executable($result);
- }
-}
-
-sub find_PL_files {
- my $self = shift;
- if (my $files = $self->{properties}{PL_files}) {
- # 'PL_files' is given as a Unix file spec, so we localize_file_path().
-
- if (UNIVERSAL::isa($files, 'ARRAY')) {
- return { map {$_, [/^(.*)\.PL$/]}
- map $self->localize_file_path($_),
- @$files };
-
- } elsif (UNIVERSAL::isa($files, 'HASH')) {
- my %out;
- while (my ($file, $to) = each %$files) {
- $out{ $self->localize_file_path($file) } = [ map $self->localize_file_path($_),
- ref $to ? @$to : ($to) ];
- }
- return \%out;
-
- } else {
- die "'PL_files' must be a hash reference or array reference";
- }
- }
-
- return unless -d 'lib';
- return {
- map {$_, [/^(.*)\.PL$/i ]}
- @{ $self->rscan_dir('lib', $self->file_qr('\.PL$')) }
- };
-}
-
-sub find_pm_files { shift->_find_file_by_type('pm', 'lib') }
-sub find_pod_files { shift->_find_file_by_type('pod', 'lib') }
-sub find_xs_files { shift->_find_file_by_type('xs', 'lib') }
-
-sub find_script_files {
- my $self = shift;
- if (my $files = $self->script_files) {
- # Always given as a Unix file spec. Values in the hash are
- # meaningless, but we preserve if present.
- return { map {$self->localize_file_path($_), $files->{$_}} keys %$files };
- }
-
- # No default location for script files
- return {};
-}
-
-sub find_test_files {
- my $self = shift;
- my $p = $self->{properties};
-
- if (my $files = $p->{test_files}) {
- $files = [keys %$files] if UNIVERSAL::isa($files, 'HASH');
- $files = [map { -d $_ ? $self->expand_test_dir($_) : $_ }
- map glob,
- $self->split_like_shell($files)];
-
- # Always given as a Unix file spec.
- return [ map $self->localize_file_path($_), @$files ];
-
- } else {
- # Find all possible tests in t/ or test.pl
- my @tests;
- push @tests, 'test.pl' if -e 'test.pl';
- push @tests, $self->expand_test_dir('t') if -e 't' and -d _;
- return \@tests;
- }
-}
-
-sub _find_file_by_type {
- my ($self, $type, $dir) = @_;
-
- if (my $files = $self->{properties}{"${type}_files"}) {
- # Always given as a Unix file spec
- return { map $self->localize_file_path($_), %$files };
- }
-
- return {} unless -d $dir;
- return { map {$_, $_}
- map $self->localize_file_path($_),
- grep !/\.\#/,
- @{ $self->rscan_dir($dir, $self->file_qr("\\.$type\$")) } };
-}
-
-sub localize_file_path {
- my ($self, $path) = @_;
- return File::Spec->catfile( split m{/}, $path );
-}
-
-sub localize_dir_path {
- my ($self, $path) = @_;
- return File::Spec->catdir( split m{/}, $path );
-}
-
-sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35
- my ($self, @files) = @_;
- my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
-
- my ($does_shbang) = $c->get('sharpbang') =~ /^\s*\#\!/;
- for my $file (@files) {
- open(my $FIXIN, '<', $file) or die "Can't process '$file': $!";
- local $/ = "\n";
- chomp(my $line = <$FIXIN>);
- next unless $line =~ s/^\s*\#!\s*//; # Not a shebang file.
-
- my ($cmd, $arg) = (split(' ', $line, 2), '');
- next unless $cmd =~ /perl/i;
- my $interpreter = $self->{properties}{perl};
-
- $self->log_verbose("Changing sharpbang in $file to $interpreter\n");
- my $shb = '';
- $shb .= $c->get('sharpbang')."$interpreter $arg\n" if $does_shbang;
-
- # I'm not smart enough to know the ramifications of changing the
- # embedded newlines here to \n, so I leave 'em in.
- $shb .= qq{
-eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
- if 0; # not running under some shell
-} unless $self->is_windowsish; # this won't work on win32, so don't
-
- open(my $FIXOUT, '>', "$file.new")
- or die "Can't create new $file: $!\n";
-
- # Print out the new #! line (or equivalent).
- local $\;
- undef $/; # Was localized above
- print $FIXOUT $shb, <$FIXIN>;
- close $FIXIN;
- close $FIXOUT;
-
- rename($file, "$file.bak")
- or die "Can't rename $file to $file.bak: $!";
-
- rename("$file.new", $file)
- or die "Can't rename $file.new to $file: $!";
-
- $self->delete_filetree("$file.bak")
- or $self->log_warn("Couldn't clean up $file.bak, leaving it there");
-
- $self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':';
- }
-}
-
-
-sub ACTION_testpod {
- my $self = shift;
- $self->depends_on('docs');
-
- eval q{use Test::Pod 0.95; 1}
- or die "The 'testpod' action requires Test::Pod version 0.95";
-
- my @files = sort keys %{$self->_find_pods($self->libdoc_dirs)},
- keys %{$self->_find_pods
- ($self->bindoc_dirs,
- exclude => [ $self->file_qr('\.bat$') ])}
- or die "Couldn't find any POD files to test\n";
-
- { package # hide from PAUSE
- Module::Build::PodTester; # Don't want to pollute the main namespace
- Test::Pod->import( tests => scalar @files );
- pod_file_ok($_) foreach @files;
- }
-}
-
-sub ACTION_testpodcoverage {
- my $self = shift;
-
- $self->depends_on('docs');
-
- eval q{use Test::Pod::Coverage 1.00; 1}
- or die "The 'testpodcoverage' action requires ",
- "Test::Pod::Coverage version 1.00";
-
- # TODO this needs test coverage!
-
- # XXX work-around a bug in Test::Pod::Coverage previous to v1.09
- # Make sure we test the module in blib/
- local @INC = @INC;
- my $p = $self->{properties};
- unshift(@INC,
- # XXX any reason to include arch?
- File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
- #File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')
- );
-
- all_pod_coverage_ok();
-}
-
-sub ACTION_docs {
- my $self = shift;
-
- $self->depends_on('code');
- $self->depends_on('manpages', 'html');
-}
-
-# Given a file type, will return true if the file type would normally
-# be installed when neither install-base nor prefix has been set.
-# I.e. it will be true only if the path is set from Config.pm or
-# set explicitly by the user via install-path.
-sub _is_default_installable {
- my $self = shift;
- my $type = shift;
- return ( $self->install_destination($type) &&
- ( $self->install_path($type) ||
- $self->install_sets($self->installdirs)->{$type} )
- ) ? 1 : 0;
-}
-
-sub _is_ActivePerl {
-# return 0;
- my $self = shift;
- unless (exists($self->{_is_ActivePerl})) {
- $self->{_is_ActivePerl} = (eval { require ActivePerl::DocTools; } || 0);
- }
- return $self->{_is_ActivePerl};
-}
-
-sub _is_ActivePPM {
-# return 0;
- my $self = shift;
- unless (exists($self->{_is_ActivePPM})) {
- $self->{_is_ActivePPM} = (eval { require ActivePerl::PPM; } || 0);
- }
- return $self->{_is_ActivePPM};
-}
-
-sub ACTION_manpages {
- my $self = shift;
-
- return unless $self->_mb_feature('manpage_support');
-
- $self->depends_on('code');
-
- my %extra_manify_args = $self->{properties}{'extra_manify_args'} ? %{ $self->{properties}{'extra_manify_args'} } : ();
-
- foreach my $type ( qw(bin lib) ) {
- next unless ( $self->invoked_action eq 'manpages' || $self->_is_default_installable("${type}doc"));
- my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
- exclude => [ $self->file_qr('\.bat$') ] );
- next unless %$files;
-
- my $sub = $self->can("manify_${type}_pods");
- $self->$sub( %extra_manify_args ) if defined( $sub );
- }
-}
-
-sub manify_bin_pods {
- my $self = shift;
- my %podman_args = (section => 1, @_); # binaries go in section 1
-
- my $files = $self->_find_pods( $self->{properties}{bindoc_dirs},
- exclude => [ $self->file_qr('\.bat$') ] );
- return unless keys %$files;
-
- my $mandir = File::Spec->catdir( $self->blib, 'bindoc' );
- File::Path::mkpath( $mandir, 0, oct(777) );
-
- require Pod::Man;
- foreach my $file (keys %$files) {
- # Pod::Simple based parsers only support one document per instance.
- # This is expected to change in a future version (Pod::Simple > 3.03).
- my $parser = Pod::Man->new( %podman_args );
- my $manpage = $self->man1page_name( $file ) . '.' .
- $self->config( 'man1ext' );
- my $outfile = File::Spec->catfile($mandir, $manpage);
- next if $self->up_to_date( $file, $outfile );
- $self->log_verbose("Manifying $file -> $outfile\n");
- eval { $parser->parse_from_file( $file, $outfile ); 1 }
- or $self->log_warn("Error creating '$outfile': $@\n");
- $files->{$file} = $outfile;
- }
-}
-
-sub manify_lib_pods {
- my $self = shift;
- my %podman_args = (section => 3, @_); # libraries go in section 3
-
- my $files = $self->_find_pods($self->{properties}{libdoc_dirs});
- return unless keys %$files;
-
- my $mandir = File::Spec->catdir( $self->blib, 'libdoc' );
- File::Path::mkpath( $mandir, 0, oct(777) );
-
- require Pod::Man;
- while (my ($file, $relfile) = each %$files) {
- # Pod::Simple based parsers only support one document per instance.
- # This is expected to change in a future version (Pod::Simple > 3.03).
- my $parser = Pod::Man->new( %podman_args );
- my $manpage = $self->man3page_name( $relfile ) . '.' .
- $self->config( 'man3ext' );
- my $outfile = File::Spec->catfile( $mandir, $manpage);
- next if $self->up_to_date( $file, $outfile );
- $self->log_verbose("Manifying $file -> $outfile\n");
- eval { $parser->parse_from_file( $file, $outfile ); 1 }
- or $self->log_warn("Error creating '$outfile': $@\n");
- $files->{$file} = $outfile;
- }
-}
-
-sub _find_pods {
- my ($self, $dirs, %args) = @_;
- my %files;
- foreach my $spec (@$dirs) {
- my $dir = $self->localize_dir_path($spec);
- next unless -e $dir;
-
- FILE: foreach my $file ( @{ $self->rscan_dir( $dir ) } ) {
- foreach my $regexp ( @{ $args{exclude} } ) {
- next FILE if $file =~ $regexp;
- }
- $file = $self->localize_file_path($file);
- $files{$file} = File::Spec->abs2rel($file, $dir) if $self->contains_pod( $file )
- }
- }
- return \%files;
-}
-
-sub contains_pod {
- my ($self, $file) = @_;
- return '' unless -T $file; # Only look at text files
-
- open(my $fh, '<', $file ) or die "Can't open $file: $!";
- while (my $line = <$fh>) {
- return 1 if $line =~ /^\=(?:head|pod|item)/;
- }
-
- return '';
-}
-
-sub ACTION_html {
- my $self = shift;
-
- return unless $self->_mb_feature('HTML_support');
-
- $self->depends_on('code');
-
- foreach my $type ( qw(bin lib) ) {
- next unless ( $self->invoked_action eq 'html' || $self->_is_default_installable("${type}html"));
- $self->htmlify_pods( $type );
- }
-}
-
-# 1) If it's an ActiveState perl install, we need to run
-# ActivePerl::DocTools->UpdateTOC;
-# 2) Links to other modules are not being generated
-sub htmlify_pods {
- my $self = shift;
- my $type = shift;
- my $htmldir = shift || File::Spec->catdir($self->blib, "${type}html");
-
- $self->add_to_cleanup('pod2htm*');
-
- my $pods = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
- exclude => [ $self->file_qr('\.(?:bat|com|html)$') ] );
- return unless %$pods; # nothing to do
-
- unless ( -d $htmldir ) {
- File::Path::mkpath($htmldir, 0, oct(755))
- or die "Couldn't mkdir $htmldir: $!";
- }
-
- my @rootdirs = ($type eq 'bin') ? qw(bin) :
- $self->installdirs eq 'core' ? qw(lib) : qw(site lib);
- my $podroot = $ENV{PERL_CORE}
- ? File::Basename::dirname($ENV{PERL_CORE})
- : $self->original_prefix('core');
-
- my $htmlroot = $self->install_sets('core')->{libhtml};
- my $podpath;
- unless (defined $self->args('html_links') and !$self->args('html_links')) {
- my @podpath = ( (map { File::Spec->abs2rel($_ ,$podroot) } grep { -d }
- ( $self->install_sets('core', 'lib'), # lib
- $self->install_sets('core', 'bin'), # bin
- $self->install_sets('site', 'lib'), # site/lib
- ) ), File::Spec->rel2abs($self->blib) );
-
- $podpath = $ENV{PERL_CORE}
- ? File::Spec->catdir($podroot, 'lib')
- : join(":", map { tr,:\\,|/,; $_ } @podpath);
- }
-
- my $blibdir = join('/', File::Spec->splitdir(
- (File::Spec->splitpath(File::Spec->rel2abs($htmldir),1))[1]),''
- );
-
- my ($with_ActiveState, $htmltool);
-
- if ( $with_ActiveState = $self->_is_ActivePerl
- && eval { require ActivePerl::DocTools::Pod; 1 }
- ) {
- my $tool_v = ActiveState::DocTools::Pod->VERSION;
- $htmltool = "ActiveState::DocTools::Pod";
- $htmltool .= " $tool_v" if $tool_v && length $tool_v;
- }
- else {
- require Module::Build::PodParser;
- require Pod::Html;
- $htmltool = "Pod::Html " . Pod::Html->VERSION;
- }
- $self->log_verbose("Converting Pod to HTML with $htmltool\n");
-
- my $errors = 0;
-
- POD:
- foreach my $pod ( keys %$pods ) {
-
- my ($name, $path) = File::Basename::fileparse($pods->{$pod},
- $self->file_qr('\.(?:pm|plx?|pod)$')
- );
- my @dirs = File::Spec->splitdir( File::Spec->canonpath( $path ) );
- pop( @dirs ) if scalar(@dirs) && $dirs[-1] eq File::Spec->curdir;
-
- my $fulldir = File::Spec->catdir($htmldir, @rootdirs, @dirs);
- my $tmpfile = File::Spec->catfile($fulldir, "${name}.tmp");
- my $outfile = File::Spec->catfile($fulldir, "${name}.html");
- my $infile = File::Spec->abs2rel($pod);
-
- next if $self->up_to_date($infile, $outfile);
-
- unless ( -d $fulldir ){
- File::Path::mkpath($fulldir, 0, oct(755))
- or die "Couldn't mkdir $fulldir: $!";
- }
-
- $self->log_verbose("HTMLifying $infile -> $outfile\n");
- if ( $with_ActiveState ) {
- my $depth = @rootdirs + @dirs;
- my %opts = ( infile => $infile,
- outfile => $tmpfile,
- ( defined($podpath) ? (podpath => $podpath) : ()),
- podroot => $podroot,
- index => 1,
- depth => $depth,
- );
- eval {
- ActivePerl::DocTools::Pod::pod2html(%opts);
- 1;
- } or $self->log_warn("[$htmltool] pod2html (" .
- join(", ", map { "q{$_} => q{$opts{$_}}" } (keys %opts)) . ") failed: $@");
- } else {
- my $path2root = File::Spec->catdir((File::Spec->updir) x @dirs);
- open(my $fh, '<', $infile) or die "Can't read $infile: $!";
- my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract();
-
- my $title = join( '::', (@dirs, $name) );
- $title .= " - $abstract" if $abstract;
-
- my @opts = (
- "--title=$title",
- ( defined($podpath) ? "--podpath=$podpath" : ()),
- "--infile=$infile",
- "--outfile=$tmpfile",
- "--podroot=$podroot",
- ($path2root ? "--htmlroot=$path2root" : ()),
- );
-
- unless ( eval{Pod::Html->VERSION(1.12)} ) {
- push( @opts, ('--flush') ); # caching removed in 1.12
- }
-
- if ( eval{Pod::Html->VERSION(1.12)} ) {
- push( @opts, ('--header', '--backlink') );
- } elsif ( eval{Pod::Html->VERSION(1.03)} ) {
- push( @opts, ('--header', '--backlink=Back to Top') );
- }
-
- $self->log_verbose("P::H::pod2html @opts\n");
- {
- my $orig = Cwd::getcwd();
- eval { Pod::Html::pod2html(@opts); 1 }
- or $self->log_warn("[$htmltool] pod2html( " .
- join(", ", map { "q{$_}" } @opts) . ") failed: $@");
- chdir($orig);
- }
- }
- # We now have to cleanup the resulting html file
- if ( ! -r $tmpfile ) {
- $errors++;
- next POD;
- }
- open(my $fh, '<', $tmpfile) or die "Can't read $tmpfile: $!";
- my $html = join('',<$fh>);
- close $fh;
- if (!$self->_is_ActivePerl) {
- # These fixups are already done by AP::DT:P:pod2html
- # The output from pod2html is NOT XHTML!
- # IE6+ will display content that is not valid for DOCTYPE
- $html =~ s#^<!DOCTYPE .*?>#<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">#im;
- $html =~ s#<html xmlns="http://www.w3.org/1999/xhtml">#<html>#i;
-
- # IE6+ will not display local HTML files with strict
- # security without this comment
- $html =~ s#<head>#<head>\n<!-- saved from url=(0017)http://localhost/ -->#i;
- }
- # Fixup links that point to our temp blib
- $html =~ s/\Q$blibdir\E//g;
-
- open($fh, '>', $outfile) or die "Can't write $outfile: $!";
- print $fh $html;
- close $fh;
- unlink($tmpfile);
- }
-
- return ! $errors;
-
-}
-
-# Adapted from ExtUtils::MM_Unix
-sub man1page_name {
- my $self = shift;
- return File::Basename::basename( shift );
-}
-
-# Adapted from ExtUtils::MM_Unix and Pod::Man
-# Depending on M::B's dependency policy, it might make more sense to refactor
-# Pod::Man::begin_pod() to extract a name() methods, and use them...
-# -spurkis
-sub man3page_name {
- my $self = shift;
- my ($vol, $dirs, $file) = File::Spec->splitpath( shift );
- my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );
-
- # Remove known exts from the base name
- $file =~ s/\.p(?:od|m|l)\z//i;
-
- return join( $self->manpage_separator, @dirs, $file );
-}
-
-sub manpage_separator {
- return '::';
-}
-
-# For systems that don't have 'diff' executable, should use Algorithm::Diff
-sub ACTION_diff {
- my $self = shift;
- $self->depends_on('build');
- my $local_lib = File::Spec->rel2abs('lib');
- my @myINC = grep {$_ ne $local_lib} @INC;
-
- # The actual install destination might not be in @INC, so check there too.
- push @myINC, map $self->install_destination($_), qw(lib arch);
-
- my @flags = @{$self->{args}{ARGV}};
- @flags = $self->split_like_shell($self->{args}{flags} || '') unless @flags;
-
- my $installmap = $self->install_map;
- delete $installmap->{read};
- delete $installmap->{write};
-
- my $text_suffix = $self->file_qr('\.(pm|pod)$');
-
- while (my $localdir = each %$installmap) {
- my @localparts = File::Spec->splitdir($localdir);
- my $files = $self->rscan_dir($localdir, sub {-f});
-
- foreach my $file (@$files) {
- my @parts = File::Spec->splitdir($file);
- @parts = @parts[@localparts .. $#parts]; # Get rid of blib/lib or similar
-
- my $installed = Module::Build::ModuleInfo->find_module_by_name(
- join('::', @parts), \@myINC );
- if (not $installed) {
- print "Only in lib: $file\n";
- next;
- }
-
- my $status = File::Compare::compare($installed, $file);
- next if $status == 0; # Files are the same
- die "Can't compare $installed and $file: $!" if $status == -1;
-
- if ($file =~ $text_suffix) {
- $self->do_system('diff', @flags, $installed, $file);
- } else {
- print "Binary files $file and $installed differ\n";
- }
- }
- }
-}
-
-sub ACTION_pure_install {
- shift()->depends_on('install');
-}
-
-sub ACTION_install {
- my ($self) = @_;
- require ExtUtils::Install;
- $self->depends_on('build');
- # RT#63003 suggest that odd circumstances that we might wind up
- # in a different directory than we started, so wrap with _do_in_dir to
- # ensure we get back to where we started; hope this fixes it!
- $self->_do_in_dir( ".", sub {
- ExtUtils::Install::install(
- $self->install_map, $self->verbose, 0, $self->{args}{uninst}||0
- );
- });
- if ($self->_is_ActivePerl && $self->{_completed_actions}{html}) {
- $self->log_info("Building ActivePerl Table of Contents\n");
- eval { ActivePerl::DocTools::WriteTOC(verbose => $self->verbose ? 1 : 0); 1; }
- or $self->log_warn("AP::DT:: WriteTOC() failed: $@");
- }
- if ($self->_is_ActivePPM) {
- # We touch 'lib/perllocal.pod'. There is an existing logic in subroutine _init_db()
- # of 'ActivePerl/PPM/InstallArea.pm' that says that if 'lib/perllocal.pod' has a 'date-last-touched'
- # greater than that of the PPM SQLite databases ('etc/ppm-perl-area.db' and/or
- # 'site/etc/ppm-site-area.db') then the PPM SQLite databases are rebuilt from scratch.
-
- # in the following line, 'perllocal.pod' this is *always* 'lib/perllocal.pod', never 'site/lib/perllocal.pod'
- my $F_perllocal = File::Spec->catfile($self->install_sets('core', 'lib'), 'perllocal.pod');
- my $dt_stamp = time;
-
- $self->log_info("For ActivePerl's PPM: touch '$F_perllocal'\n");
-
- open my $perllocal, ">>", $F_perllocal;
- close $perllocal;
- utime($dt_stamp, $dt_stamp, $F_perllocal);
- }
-}
-
-sub ACTION_fakeinstall {
- my ($self) = @_;
- require ExtUtils::Install;
- my $eui_version = ExtUtils::Install->VERSION;
- if ( $eui_version < 1.32 ) {
- $self->log_warn(
- "The 'fakeinstall' action requires Extutils::Install 1.32 or later.\n"
- . "(You only have version $eui_version)."
- );
- return;
- }
- $self->depends_on('build');
- ExtUtils::Install::install($self->install_map, !$self->quiet, 1, $self->{args}{uninst}||0);
-}
-
-sub ACTION_versioninstall {
- my ($self) = @_;
-
- die "You must have only.pm 0.25 or greater installed for this operation: $@\n"
- unless eval { require only; 'only'->VERSION(0.25); 1 };
-
- $self->depends_on('build');
-
- my %onlyargs = map {exists($self->{args}{$_}) ? ($_ => $self->{args}{$_}) : ()}
- qw(version versionlib);
- only::install::install(%onlyargs);
-}
-
-sub ACTION_installdeps {
- my ($self) = @_;
-
- # XXX include feature prerequisites as optional prereqs?
-
- my $info = $self->_enum_prereqs;
- if (! $info ) {
- $self->log_info( "No prerequisites detected\n" );
- return;
- }
-
- my $failures = $self->prereq_failures($info);
- if ( ! $failures ) {
- $self->log_info( "All prerequisites satisfied\n" );
- return;
- }
-
- my @install;
- while (my ($type, $prereqs) = each %$failures) {
- if($type =~ m/^(?:\w+_)?requires$/) {
- push(@install, keys %$prereqs);
- next;
- }
- $self->log_info("Checking optional dependencies:\n");
- while (my ($module, $status) = each %$prereqs) {
- push(@install, $module) if($self->y_n("Install $module?", 'y'));
- }
- }
-
- return unless @install;
-
- my ($command, @opts) = $self->split_like_shell($self->cpan_client);
-
- # relative command should be relative to our active Perl
- # so we need to locate that command
- if ( ! File::Spec->file_name_is_absolute( $command ) ) {
- # prefer site to vendor to core
- my @loc = ( 'site', 'vendor', '' );
- my @bindirs = File::Basename::dirname($self->perl);
- push @bindirs,
- map {
- ($self->config->{"install${_}bin"}, $self->config->{"install${_}script"})
- } @loc;
- for my $d ( @bindirs ) {
- my $abs_cmd = $self->find_command(File::Spec->catfile( $d, $command ));
- if ( defined $abs_cmd ) {
- $command = $abs_cmd;
- last;
- }
- }
- }
-
- $self->do_system($command, @opts, @install);
-}
-
-sub ACTION_clean {
- my ($self) = @_;
- $self->log_info("Cleaning up build files\n");
- foreach my $item (map glob($_), $self->cleanup) {
- $self->delete_filetree($item);
- }
-}
-
-sub ACTION_realclean {
- my ($self) = @_;
- $self->depends_on('clean');
- $self->log_info("Cleaning up configuration files\n");
- $self->delete_filetree(
- $self->config_dir, $self->mymetafile, $self->mymetafile2, $self->build_script
- );
-}
-
-sub ACTION_ppd {
- my ($self) = @_;
-
- require Module::Build::PPMMaker;
- my $ppd = Module::Build::PPMMaker->new();
- my $file = $ppd->make_ppd(%{$self->{args}}, build => $self);
- $self->add_to_cleanup($file);
-}
-
-sub ACTION_ppmdist {
- my ($self) = @_;
-
- $self->depends_on( 'build' );
-
- my $ppm = $self->ppm_name;
- $self->delete_filetree( $ppm );
- $self->log_info( "Creating $ppm\n" );
- $self->add_to_cleanup( $ppm, "$ppm.tar.gz" );
-
- my %types = ( # translate types/dirs to those expected by ppm
- lib => 'lib',
- arch => 'arch',
- bin => 'bin',
- script => 'script',
- bindoc => 'man1',
- libdoc => 'man3',
- binhtml => undef,
- libhtml => undef,
- );
-
- foreach my $type ($self->install_types) {
- next if exists( $types{$type} ) && !defined( $types{$type} );
-
- my $dir = File::Spec->catdir( $self->blib, $type );
- next unless -e $dir;
-
- my $files = $self->rscan_dir( $dir );
- foreach my $file ( @$files ) {
- next unless -f $file;
- my $rel_file =
- File::Spec->abs2rel( File::Spec->rel2abs( $file ),
- File::Spec->rel2abs( $dir ) );
- my $to_file =
- File::Spec->catfile( $ppm, 'blib',
- exists( $types{$type} ) ? $types{$type} : $type,
- $rel_file );
- $self->copy_if_modified( from => $file, to => $to_file );
- }
- }
-
- foreach my $type ( qw(bin lib) ) {
- $self->htmlify_pods( $type, File::Spec->catdir($ppm, 'blib', 'html') );
- }
-
- # create a tarball;
- # the directory tar'ed must be blib so we need to do a chdir first
- my $target = File::Spec->catfile( File::Spec->updir, $ppm );
- $self->_do_in_dir( $ppm, sub { $self->make_tarball( 'blib', $target ) } );
-
- $self->depends_on( 'ppd' );
-
- $self->delete_filetree( $ppm );
-}
-
-sub ACTION_pardist {
- my ($self) = @_;
-
- # Need PAR::Dist
- if ( not eval { require PAR::Dist; PAR::Dist->VERSION(0.17) } ) {
- $self->log_warn(
- "In order to create .par distributions, you need to\n"
- . "install PAR::Dist first."
- );
- return();
- }
-
- $self->depends_on( 'build' );
-
- return PAR::Dist::blib_to_par(
- name => $self->dist_name,
- version => $self->dist_version,
- );
-}
-
-sub ACTION_dist {
- my ($self) = @_;
-
- # MUST dispatch() and not depends_ok() so we generate a clean distdir
- $self->dispatch('distdir');
-
- my $dist_dir = $self->dist_dir;
-
- $self->make_tarball($dist_dir);
- $self->delete_filetree($dist_dir);
-}
-
-sub ACTION_distcheck {
- my ($self) = @_;
-
- $self->_check_manifest_skip unless $self->invoked_action eq 'distclean';
-
- require ExtUtils::Manifest;
- local $^W; # ExtUtils::Manifest is not warnings clean.
- my ($missing, $extra) = ExtUtils::Manifest::fullcheck();
-
- return unless @$missing || @$extra;
-
- my $msg = "MANIFEST appears to be out of sync with the distribution\n";
- if ( $self->invoked_action eq 'distcheck' ) {
- die $msg;
- } else {
- warn $msg;
- }
-}
-
-sub _check_mymeta_skip {
- my $self = shift;
- my $maniskip = shift || 'MANIFEST.SKIP';
-
- require ExtUtils::Manifest;
- local $^W; # ExtUtils::Manifest is not warnings clean.
-
- # older ExtUtils::Manifest had a private _maniskip
- my $skip_factory = ExtUtils::Manifest->can('maniskip')
- || ExtUtils::Manifest->can('_maniskip');
-
- my $mymetafile = $self->mymetafile;
- # we can't check it, just add it anyway to be safe
- for my $file ( $self->mymetafile, $self->mymetafile2 ) {
- unless ( $skip_factory && $skip_factory->($maniskip)->($file) ) {
- $self->log_warn("File '$maniskip' does not include '$file'. Adding it now.\n");
- my $safe = quotemeta($file);
- $self->_append_maniskip("^$safe\$", $maniskip);
- }
- }
-}
-
-sub _add_to_manifest {
- my ($self, $manifest, $lines) = @_;
- $lines = [$lines] unless ref $lines;
-
- my $existing_files = $self->_read_manifest($manifest);
- return unless defined( $existing_files );
-
- @$lines = grep {!exists $existing_files->{$_}} @$lines
- or return;
-
- my $mode = (stat $manifest)[2];
- chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!";
-
- open(my $fh, '<', $manifest) or die "Can't read $manifest: $!";
- my $last_line = (<$fh>)[-1] || "\n";
- my $has_newline = $last_line =~ /\n$/;
- close $fh;
-
- open($fh, '>>', $manifest) or die "Can't write to $manifest: $!";
- print $fh "\n" unless $has_newline;
- print $fh map "$_\n", @$lines;
- close $fh;
- chmod($mode, $manifest);
-
- $self->log_verbose(map "Added to $manifest: $_\n", @$lines);
-}
-
-sub _sign_dir {
- my ($self, $dir) = @_;
-
- unless (eval { require Module::Signature; 1 }) {
- $self->log_warn("Couldn't load Module::Signature for 'distsign' action:\n $@\n");
- return;
- }
-
- # Add SIGNATURE to the MANIFEST
- {
- my $manifest = File::Spec->catfile($dir, 'MANIFEST');
- die "Signing a distribution requires a MANIFEST file" unless -e $manifest;
- $self->_add_to_manifest($manifest, "SIGNATURE Added here by Module::Build");
- }
-
- # Would be nice if Module::Signature took a directory argument.
-
- $self->_do_in_dir($dir, sub {local $Module::Signature::Quiet = 1; Module::Signature::sign()});
-}
-
-sub _do_in_dir {
- my ($self, $dir, $do) = @_;
-
- my $start_dir = File::Spec->rel2abs($self->cwd);
- chdir $dir or die "Can't chdir() to $dir: $!";
- eval {$do->()};
- my @err = $@ ? ($@) : ();
- chdir $start_dir or push @err, "Can't chdir() back to $start_dir: $!";
- die join "\n", @err if @err;
-}
-
-sub ACTION_distsign {
- my ($self) = @_;
- {
- local $self->{properties}{sign} = 0; # We'll sign it ourselves
- $self->depends_on('distdir') unless -d $self->dist_dir;
- }
- $self->_sign_dir($self->dist_dir);
-}
-
-sub ACTION_skipcheck {
- my ($self) = @_;
-
- require ExtUtils::Manifest;
- local $^W; # ExtUtils::Manifest is not warnings clean.
- ExtUtils::Manifest::skipcheck();
-}
-
-sub ACTION_distclean {
- my ($self) = @_;
-
- $self->depends_on('realclean');
- $self->depends_on('distcheck');
-}
-
-sub do_create_makefile_pl {
- my $self = shift;
- require Module::Build::Compat;
- $self->log_info("Creating Makefile.PL\n");
- eval { Module::Build::Compat->create_makefile_pl($self->create_makefile_pl, $self, @_) };
- if ( $@ ) {
- 1 while unlink 'Makefile.PL';
- die "$@\n";
- }
- $self->_add_to_manifest('MANIFEST', 'Makefile.PL');
-}
-
-sub do_create_license {
- my $self = shift;
- $self->log_info("Creating LICENSE file\n");
-
- if ( ! $self->_mb_feature('license_creation') ) {
- $self->_warn_mb_feature_deps('license_creation');
- die "Aborting.\n";
- }
-
- my $l = $self->license
- or die "Can't create LICENSE file: No license specified\n";
-
- my $license = $self->_software_license_object
- or die << "HERE";
-Can't create LICENSE file: '$l' is not a valid license key
-or Software::License subclass;
-HERE
-
- $self->delete_filetree('LICENSE');
-
- open(my $fh, '>', 'LICENSE')
- or die "Can't write LICENSE file: $!";
- print $fh $license->fulltext;
- close $fh;
-
- $self->_add_to_manifest('MANIFEST', 'LICENSE');
-}
-
-sub do_create_readme {
- my $self = shift;
- $self->delete_filetree('README');
-
- my $docfile = $self->_main_docfile;
- unless ( $docfile ) {
- $self->log_warn(<<EOF);
-Cannot create README: can't determine which file contains documentation;
-Must supply either 'dist_version_from', or 'module_name' parameter.
-EOF
- return;
- }
-
- # work around some odd Pod::Readme->new() failures in test reports by
- # confirming that new() is available
- if ( eval {require Pod::Readme; Pod::Readme->can('new') } ) {
- $self->log_info("Creating README using Pod::Readme\n");
-
- my $parser = Pod::Readme->new;
- $parser->parse_from_file($docfile, 'README', @_);
-
- } elsif ( eval {require Pod::Text; 1} ) {
- $self->log_info("Creating README using Pod::Text\n");
-
- if ( open(my $fh, '>', 'README') ) {
- local $^W = 0;
- no strict "refs";
-
- # work around bug in Pod::Text 3.01, which expects
- # Pod::Simple::parse_file to take input and output filehandles
- # when it actually only takes an input filehandle
-
- my $old_parse_file;
- $old_parse_file = \&{"Pod::Simple::parse_file"}
- and
- local *{"Pod::Simple::parse_file"} = sub {
- my $self = shift;
- $self->output_fh($_[1]) if $_[1];
- $self->$old_parse_file($_[0]);
- }
- if $Pod::Text::VERSION
- == 3.01; # Split line to avoid evil version-finder
-
- Pod::Text::pod2text( $docfile, $fh );
-
- close $fh;
- } else {
- $self->log_warn(
- "Cannot create 'README' file: Can't open file for writing\n" );
- return;
- }
-
- } else {
- $self->log_warn("Can't load Pod::Readme or Pod::Text to create README\n");
- return;
- }
-
- $self->_add_to_manifest('MANIFEST', 'README');
-}
-
-sub _main_docfile {
- my $self = shift;
- if ( my $pm_file = $self->dist_version_from ) {
- (my $pod_file = $pm_file) =~ s/.pm$/.pod/;
- return (-e $pod_file ? $pod_file : $pm_file);
- } else {
- return undef;
- }
-}
-
-sub do_create_bundle_inc {
- my $self = shift;
- my $dist_inc = File::Spec->catdir( $self->dist_dir, 'inc' );
- require inc::latest;
- inc::latest->write($dist_inc, @{$self->bundle_inc_preload});
- inc::latest->bundle_module($_, $dist_inc) for @{$self->bundle_inc};
- return 1;
-}
-
-sub ACTION_distdir {
- my ($self) = @_;
-
- if ( @{$self->bundle_inc} && ! $self->_mb_feature('inc_bundling_support') ) {
- $self->_warn_mb_feature_deps('inc_bundling_support');
- die "Aborting.\n";
- }
-
- $self->depends_on('distmeta');
-
- my $dist_files = $self->_read_manifest('MANIFEST')
- or die "Can't create distdir without a MANIFEST file - run 'manifest' action first.\n";
- delete $dist_files->{SIGNATURE}; # Don't copy, create a fresh one
- die "No files found in MANIFEST - try running 'manifest' action?\n"
- unless ($dist_files and keys %$dist_files);
- my $metafile = $self->metafile;
- $self->log_warn("*** Did you forget to add $metafile to the MANIFEST?\n")
- unless exists $dist_files->{$metafile};
-
- my $dist_dir = $self->dist_dir;
- $self->delete_filetree($dist_dir);
- $self->log_info("Creating $dist_dir\n");
- $self->add_to_cleanup($dist_dir);
-
- foreach my $file (keys %$dist_files) {
- next if $file =~ m{^MYMETA\.}; # Double check that we skip MYMETA.*
- my $new = $self->copy_if_modified(from => $file, to_dir => $dist_dir, verbose => 0);
- }
-
- $self->do_create_bundle_inc if @{$self->bundle_inc};
-
- $self->_sign_dir($dist_dir) if $self->{properties}{sign};
-}
-
-sub ACTION_disttest {
- my ($self) = @_;
-
- $self->depends_on('distdir');
-
- $self->_do_in_dir
- ( $self->dist_dir,
- sub {
- # XXX could be different names for scripts
-
- $self->run_perl_script('Build.PL') # XXX Should this be run w/ --nouse-rcfile
- or die "Error executing 'Build.PL' in dist directory: $!";
- $self->run_perl_script($self->build_script)
- or die "Error executing $self->build_script in dist directory: $!";
- $self->run_perl_script($self->build_script, [], ['test'])
- or die "Error executing 'Build test' in dist directory";
- });
-}
-
-sub ACTION_distinstall {
- my ($self, @args) = @_;
-
- $self->depends_on('distdir');
-
- $self->_do_in_dir ( $self->dist_dir,
- sub {
- $self->run_perl_script('Build.PL')
- or die "Error executing 'Build.PL' in dist directory: $!";
- $self->run_perl_script($self->build_script)
- or die "Error executing $self->build_script in dist directory: $!";
- $self->run_perl_script($self->build_script, [], ['install'])
- or die "Error executing 'Build install' in dist directory";
- }
- );
-}
-
-=begin private
-
- my $has_include = $build->_eumanifest_has_include;
-
-Returns true if the installed version of ExtUtils::Manifest supports
-#include and #include_default directives. False otherwise.
-
-=end private
-
-=cut
-
-# #!include and #!include_default were added in 1.50
-sub _eumanifest_has_include {
- my $self = shift;
-
- require ExtUtils::Manifest;
- return eval { ExtUtils::Manifest->VERSION(1.50); 1 };
-}
-
-
-=begin private
-
- my $maniskip_file = $build->_default_maniskip;
-
-Returns the location of the installed MANIFEST.SKIP file used by
-default.
-
-=end private
-
-=cut
-
-sub _default_maniskip {
- my $self = shift;
-
- my $default_maniskip;
- for my $dir (@INC) {
- $default_maniskip = File::Spec->catfile($dir, "ExtUtils", "MANIFEST.SKIP");
- last if -r $default_maniskip;
- }
-
- return $default_maniskip;
-}
-
-
-=begin private
-
- my $content = $build->_slurp($file);
-
-Reads $file and returns the $content.
-
-=end private
-
-=cut
-
-sub _slurp {
- my $self = shift;
- my $file = shift;
- my $mode = shift || "";
- open my $fh, "<$mode", $file or croak "Can't open $file for reading: $!";
- local $/;
- return <$fh>;
-}
-
-sub _spew {
- my $self = shift;
- my $file = shift;
- my $content = shift || "";
- my $mode = shift || "";
- open my $fh, ">$mode", $file or croak "Can't open $file for writing: $!";
- print {$fh} $content;
- close $fh;
-}
-
-sub _case_tolerant {
- my $self = shift;
- if ( ref $self ) {
- $self->{_case_tolerant} = File::Spec->case_tolerant
- unless defined($self->{_case_tolerant});
- return $self->{_case_tolerant};
- }
- else {
- return File::Spec->case_tolerant;
- }
-}
-
-sub _append_maniskip {
- my $self = shift;
- my $skip = shift;
- my $file = shift || 'MANIFEST.SKIP';
- return unless defined $skip && length $skip;
- open(my $fh, '>>', $file)
- or die "Can't open $file: $!";
-
- print $fh "$skip\n";
- close $fh;
-}
-
-sub _write_default_maniskip {
- my $self = shift;
- my $file = shift || 'MANIFEST.SKIP';
- open(my $fh, '>', $file)
- or die "Can't open $file: $!";
-
- my $content = $self->_eumanifest_has_include ? "#!include_default\n"
- : $self->_slurp( $self->_default_maniskip );
-
- $content .= <<'EOF';
-# Avoid configuration metadata file
-^MYMETA\.
-
-# Avoid Module::Build generated and utility files.
-\bBuild$
-\bBuild.bat$
-\b_build
-\bBuild.COM$
-\bBUILD.COM$
-\bbuild.com$
-^MANIFEST\.SKIP
-
-# Avoid archives of this distribution
-EOF
-
- # Skip, for example, 'Module-Build-0.27.tar.gz'
- $content .= '\b'.$self->dist_name.'-[\d\.\_]+'."\n";
-
- print $fh $content;
-
- close $fh;
-
- return;
-}
-
-sub _check_manifest_skip {
- my ($self) = @_;
-
- my $maniskip = 'MANIFEST.SKIP';
-
- if ( ! -e $maniskip ) {
- $self->log_warn("File '$maniskip' does not exist: Creating a temporary '$maniskip'\n");
- $self->_write_default_maniskip($maniskip);
- $self->_unlink_on_exit($maniskip);
- }
- else {
- # MYMETA must not be added to MANIFEST, so always confirm the skip
- $self->_check_mymeta_skip( $maniskip );
- }
-
- return;
-}
-
-sub ACTION_manifest {
- my ($self) = @_;
-
- $self->_check_manifest_skip;
-
- require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean.
- local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
- ExtUtils::Manifest::mkmanifest();
-}
-
-sub ACTION_manifest_skip {
- my ($self) = @_;
-
- if ( -e 'MANIFEST.SKIP' ) {
- $self->log_warn("MANIFEST.SKIP already exists.\n");
- return 0;
- }
- $self->log_info("Creating a new MANIFEST.SKIP file\n");
- return $self->_write_default_maniskip;
- return -e 'MANIFEST.SKIP'
-}
-
-# Case insensitive regex for files
-sub file_qr {
- return shift->{_case_tolerant} ? qr($_[0])i : qr($_[0]);
-}
-
-sub dist_dir {
- my ($self) = @_;
- my $dir = join "-", $self->dist_name, $self->dist_version;
- $dir .= "-" . $self->dist_suffix if $self->dist_suffix;
- return $dir;
-}
-
-sub ppm_name {
- my $self = shift;
- return 'PPM-' . $self->dist_dir;
-}
-
-sub _files_in {
- my ($self, $dir) = @_;
- return unless -d $dir;
-
- local *DH;
- opendir DH, $dir or die "Can't read directory $dir: $!";
-
- my @files;
- while (defined (my $file = readdir DH)) {
- my $full_path = File::Spec->catfile($dir, $file);
- next if -d $full_path;
- push @files, $full_path;
- }
- return @files;
-}
-
-sub share_dir {
- my $self = shift;
- my $p = $self->{properties};
-
- $p->{share_dir} = shift if @_;
-
- # Always coerce to proper hash form
- if ( ! defined $p->{share_dir} ) {
- return;
- }
- elsif ( ! ref $p->{share_dir} ) {
- # scalar -- treat as a single 'dist' directory
- $p->{share_dir} = { dist => [ $p->{share_dir} ] };
- }
- elsif ( ref $p->{share_dir} eq 'ARRAY' ) {
- # array -- treat as a list of 'dist' directories
- $p->{share_dir} = { dist => $p->{share_dir} };
- }
- elsif ( ref $p->{share_dir} eq 'HASH' ) {
- # hash -- check structure
- my $share_dir = $p->{share_dir};
- # check dist key
- if ( defined $share_dir->{dist} ) {
- if ( ! ref $share_dir->{dist} ) {
- # scalar, so upgrade to arrayref
- $share_dir->{dist} = [ $share_dir->{dist} ];
- }
- elsif ( ref $share_dir->{dist} ne 'ARRAY' ) {
- die "'dist' key in 'share_dir' must be scalar or arrayref";
- }
- }
- # check module key
- if ( defined $share_dir->{module} ) {
- my $mod_hash = $share_dir->{module};
- if ( ref $mod_hash eq 'HASH' ) {
- for my $k ( keys %$mod_hash ) {
- if ( ! ref $mod_hash->{$k} ) {
- $mod_hash->{$k} = [ $mod_hash->{$k} ];
- }
- elsif( ref $mod_hash->{$k} ne 'ARRAY' ) {
- die "modules in 'module' key of 'share_dir' must be scalar or arrayref";
- }
- }
- }
- else {
- die "'module' key in 'share_dir' must be hashref";
- }
- }
- }
- else {
- die "'share_dir' must be hashref, arrayref or string";
- }
-
- return $p->{share_dir};
-}
-
-sub script_files {
- my $self = shift;
-
- for ($self->{properties}{script_files}) {
- $_ = shift if @_;
- next unless $_;
-
- # Always coerce into a hash
- return $_ if UNIVERSAL::isa($_, 'HASH');
- return $_ = { map {$_,1} @$_ } if UNIVERSAL::isa($_, 'ARRAY');
-
- die "'script_files' must be a hashref, arrayref, or string" if ref();
-
- return $_ = { map {$_,1} $self->_files_in( $_ ) } if -d $_;
- return $_ = {$_ => 1};
- }
-
- my %pl_files = map {
- File::Spec->canonpath( $_ ) => 1
- } keys %{ $self->PL_files || {} };
-
- my @bin_files = $self->_files_in('bin');
-
- my %bin_map = map {
- $_ => File::Spec->canonpath( $_ )
- } @bin_files;
-
- return $_ = { map {$_ => 1} grep !$pl_files{$bin_map{$_}}, @bin_files };
-}
-BEGIN { *scripts = \&script_files; }
-
-{
- my %licenses = (
- perl => 'Perl_5',
- apache => 'Apache_2_0',
- apache_1_1 => 'Apache_1_1',
- artistic => 'Artistic_1',
- artistic_2 => 'Artistic_2',
- lgpl => 'LGPL_2_1',
- lgpl2 => 'LGPL_2_1',
- lgpl3 => 'LGPL_3_0',
- bsd => 'BSD',
- gpl => 'GPL_1',
- gpl2 => 'GPL_2',
- gpl3 => 'GPL_3',
- mit => 'MIT',
- mozilla => 'Mozilla_1_1',
- restrictive => 'Restricted',
- open_source => undef,
- unrestricted => undef,
- unknown => undef,
- );
-
- # TODO - would be nice to not have these here, since they're more
- # properly stored only in Software::License
- my %license_urls = (
- perl => 'http://dev.perl.org/licenses/',
- apache => 'http://apache.org/licenses/LICENSE-2.0',
- apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
- artistic => 'http://opensource.org/licenses/artistic-license.php',
- artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
- lgpl => 'http://opensource.org/licenses/lgpl-license.php',
- lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
- lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
- bsd => 'http://opensource.org/licenses/bsd-license.php',
- gpl => 'http://opensource.org/licenses/gpl-license.php',
- gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
- gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
- mit => 'http://opensource.org/licenses/mit-license.php',
- mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
- restrictive => undef,
- open_source => undef,
- unrestricted => undef,
- unknown => undef,
- );
- sub valid_licenses {
- return \%licenses;
- }
- sub _license_url {
- return $license_urls{$_[1]};
- }
-}
-
-sub _software_license_class {
- my ($self, $license) = @_;
- if ($self->valid_licenses->{$license} && eval { require Software::LicenseUtils; Software::LicenseUtils->VERSION(0.103009) }) {
- my ($class) = Software::LicenseUtils->guess_license_from_meta_key($license, 1);
- eval "require $class";
- #die $class;
- return $class;
- }
- LICENSE: for my $l ( $self->valid_licenses->{ $license }, $license ) {
- next unless defined $l;
- my $trial = "Software::License::" . $l;
- if ( eval "require Software::License; Software::License->VERSION(0.014); require $trial; 1" ) {
- return $trial;
- }
- }
- return;
-}
-
-# use mapping or license name directly
-sub _software_license_object {
- my ($self) = @_;
- return unless defined( my $license = $self->license );
-
- my $class = $self->_software_license_class($license) or return;
-
- # Software::License requires a 'holder' argument
- my $author = join( " & ", @{ $self->dist_author }) || 'unknown';
- my $sl = eval { $class->new({holder=>$author}) };
- if ( $@ ) {
- $self->log_warn( "Error getting '$class' object: $@" );
- }
-
- return $sl;
-}
-
-sub _hash_merge {
- my ($self, $h, $k, $v) = @_;
- if (ref $h->{$k} eq 'ARRAY') {
- push @{$h->{$k}}, ref $v ? @$v : $v;
- } elsif (ref $h->{$k} eq 'HASH') {
- $h->{$k}{$_} = $v->{$_} foreach keys %$v;
- } else {
- $h->{$k} = $v;
- }
-}
-
-sub ACTION_distmeta {
- my ($self) = @_;
- $self->do_create_makefile_pl if $self->create_makefile_pl;
- $self->do_create_readme if $self->create_readme;
- $self->do_create_license if $self->create_license;
- $self->do_create_metafile;
-}
-
-sub do_create_metafile {
- my $self = shift;
- return if $self->{wrote_metadata};
-
- my $p = $self->{properties};
-
- unless ($p->{license}) {
- $self->log_warn("No license specified, setting license = 'unknown'\n");
- $p->{license} = 'unknown';
- }
-
- my @metafiles = ( $self->metafile, $self->metafile2 );
- # If we're in the distdir, the metafile may exist and be non-writable.
- $self->delete_filetree($_) for @metafiles;
-
- # Since we're building ourself, we have to do some special stuff
- # here: the ConfigData module is found in blib/lib.
- local @INC = @INC;
- if (($self->module_name || '') eq 'Module::Build') {
- $self->depends_on('config_data');
- push @INC, File::Spec->catdir($self->blib, 'lib');
- }
-
- my $meta_obj = $self->_get_meta_object(
- quiet => 1, fatal => 1, auto => 1
- );
- my @created = $self->_write_meta_files( $meta_obj, 'META' );
- if ( @created ) {
- $self->{wrote_metadata} = 1;
- $self->_add_to_manifest('MANIFEST', $_) for @created;
- }
- return 1;
-}
-
-sub _write_meta_files {
- my $self = shift;
- my ($meta, $file) = @_;
- $file =~ s{\.(?:yml|json)$}{};
-
- my @created;
- push @created, "$file\.yml"
- if $meta && $meta->save( "$file\.yml", {version => "1.4"} );
- push @created, "$file\.json"
- if $meta && $meta->save( "$file\.json" );
-
- if ( @created ) {
- $self->log_info("Created " . join(" and ", @created) . "\n");
- }
- return @created;
-}
-
-sub _get_meta_object {
- my $self = shift;
- my %args = @_;
- return unless $self->try_require("CPAN::Meta", "2.110420");
-
- my $meta;
- eval {
- my $data = $self->get_metadata(
- fatal => $args{fatal},
- auto => $args{auto},
- );
- $data->{dynamic_config} = $args{dynamic} if defined $args{dynamic};
- $meta = CPAN::Meta->create($data);
- };
- if ($@ && ! $args{quiet}) {
- $self->log_warn(
- "Could not get valid metadata. Error is: $@\n"
- );
- }
-
- return $meta;
-}
-
-# We return a version 1.4 structure for backwards compatibility
-sub read_metafile {
- my $self = shift;
- my ($metafile) = @_;
-
- return unless $self->try_require("CPAN::Meta", "2.110420");
- my $meta = CPAN::Meta->load_file($metafile);
- return $meta->as_struct( {version => "1.4"} );
-}
-
-# For legacy compatibility, we upconvert a 1.4 data structure, ensuring
-# validity, and then downconvert it back to save it.
-#
-# generally, this code should no longer be used
-sub write_metafile {
- my $self = shift;
- my ($metafile, $struct) = @_;
-
- return unless $self->try_require("CPAN::Meta", "2.110420");
-
- my $meta = CPAN::Meta->new( $struct );
- return $meta->save( $metafile, { version => "1.4" } );
-}
-
-sub normalize_version {
- my ($self, $version) = @_;
- $version = 0 unless defined $version and length $version;
-
- if ( $version =~ /[=<>!,]/ ) { # logic, not just version
- # take as is without modification
- }
- elsif ( ref $version eq 'version' ||
- ref $version eq 'Module::Build::Version' ) { # version objects
- $version = $version->is_qv ? $version->normal : $version->stringify;
- }
- elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
- # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
- $version = "v$version";
- }
- else {
- # leave alone
- }
- return $version;
-}
-
-my %prereq_map = (
- requires => [ qw/runtime requires/],
- configure_requires => [qw/configure requires/],
- build_requires => [ qw/build requires/ ],
- test_requires => [ qw/test requires/ ],
- test_recommends => [ qw/test recommends/ ],
- recommends => [ qw/runtime recommends/ ],
- conflicts => [ qw/runtime conflicts/ ],
-);
-
-sub _normalize_prereqs {
- my ($self) = @_;
- my $p = $self->{properties};
-
- # copy prereq data structures so we can modify them before writing to META
- my %prereq_types;
- for my $type ( 'configure_requires', @{$self->prereq_action_types} ) {
- if (exists $p->{$type} and keys %{ $p->{$type} }) {
- my ($phase, $relation) = @{ $prereq_map{$type} };
- for my $mod ( keys %{ $p->{$type} } ) {
- $prereq_types{$phase}{$relation}{$mod} = $self->normalize_version($p->{$type}{$mod});
- }
- }
- }
- return \%prereq_types;
-}
-
-sub _get_license {
- my $self = shift;
-
- my $license = $self->license;
- my ($meta_license, $meta_license_url);
-
- my $valid_licenses = $self->valid_licenses();
- if ( my $sl = $self->_software_license_object ) {
- $meta_license = $sl->meta2_name;
- $meta_license_url = $sl->url;
- }
- elsif ( exists $valid_licenses->{$license} ) {
- $meta_license = $valid_licenses->{$license} ? lc $valid_licenses->{$license} : $license;
- $meta_license_url = $self->_license_url( $license );
- }
- else {
- $self->log_warn( "Can not determine license type for '" . $self->license
- . "'\nSetting META license field to 'unknown'.\n");
- $meta_license = 'unknown';
- }
- return ($meta_license, $meta_license_url);
-}
-
-my %keep = map { $_ => 1 } qw/keywords dynamic_config provides no_index name version abstract/;
-my %ignore = map { $_ => 1 } qw/distribution_type/;
-my %reject = map { $_ => 1 } qw/private author license requires recommends build_requires configure_requires conflicts/;
-
-sub _upconvert_resources {
- my ($input) = @_;
- my %output;
- for my $key (keys %{$input}) {
- my $out_key = $key =~ /^\p{Lu}/ ? "x_\l$key" : $key;
- if ($key eq 'repository') {
- my $name = $input->{$key} =~ m{ \A http s? :// .* (<! \.git ) \z }xms ? 'web' : 'url';
- $output{$out_key} = { $name => $input->{$key} };
- }
- elsif ($key eq 'bugtracker') {
- $output{$out_key} = { web => $input->{$key} }
- }
- else {
- $output{$out_key} = $input->{$key};
- }
- }
- return \%output
-}
-my %custom = (
- resources => \&_upconvert_resources,
-);
-
-sub _upconvert_metapiece {
- my ($input, $type) = @_;
- return $input if exists $input->{'meta-spec'} && $input->{'meta-spec'}{version} == 2;
-
- my %ret;
- for my $key (keys %{$input}) {
- if ($keep{$key}) {
- $ret{$key} = $input->{$key};
- }
- elsif ($ignore{$key}) {
- next;
- }
- elsif ($reject{$key}) {
- croak "Can't $type $key, please use another mechanism";
- }
- elsif (my $converter = $custom{$key}) {
- $ret{$key} = $converter->($input->{$key});
- }
- else {
- my $out_key = $key =~ / \A x_ /xi ? $key : "x_$key";
- $ret{$out_key} = $input->{$key};
- }
- }
- return \%ret;
-}
-
-sub get_metadata {
- my ($self, %args) = @_;
-
- my $fatal = $args{fatal} || 0;
- my $p = $self->{properties};
-
- $self->auto_config_requires if $args{auto};
-
- # validate required fields
- foreach my $f (qw(dist_name dist_version dist_author dist_abstract license)) {
- my $field = $self->$f();
- unless ( defined $field and length $field ) {
- my $err = "ERROR: Missing required field '$f' for metafile\n";
- if ( $fatal ) {
- die $err;
- }
- else {
- $self->log_warn($err);
- }
- }
- }
-
- my %metadata = (
- name => $self->dist_name,
- version => $self->normalize_version($self->dist_version),
- author => $self->dist_author,
- abstract => $self->dist_abstract,
- generated_by => "Module::Build version $Module::Build::VERSION",
- 'meta-spec' => {
- version => '2',
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- },
- dynamic_config => exists $p->{dynamic_config} ? $p->{dynamic_config} : 1,
- release_status => $self->release_status,
- );
-
- my ($meta_license, $meta_license_url) = $self->_get_license;
- $metadata{license} = [ $meta_license ];
- $metadata{resources}{license} = [ $meta_license_url ] if defined $meta_license_url;
-
- $metadata{prereqs} = $self->_normalize_prereqs;
-
- if (exists $p->{no_index}) {
- $metadata{no_index} = $p->{no_index};
- } elsif (my $pkgs = eval { $self->find_dist_packages }) {
- $metadata{provides} = $pkgs if %$pkgs;
- } else {
- $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" .
- "Nothing to enter for 'provides' field in metafile.\n");
- }
-
- my $meta_add = _upconvert_metapiece($self->meta_add, 'add');
- while (my($k, $v) = each %{$meta_add} ) {
- $metadata{$k} = $v;
- }
-
- my $meta_merge = _upconvert_metapiece($self->meta_merge, 'merge');
- while (my($k, $v) = each %{$meta_merge} ) {
- $self->_hash_merge(\%metadata, $k, $v);
- }
-
- return \%metadata;
-}
-
-# To preserve compatibility with old API, $node *must* be a hashref
-# passed in to prepare_metadata. $keys is an arrayref holding a
-# list of keys -- it's use is optional and generally no longer needed
-# but kept for back compatibility. $args is an optional parameter to
-# support the new 'fatal' toggle
-
-sub prepare_metadata {
- my ($self, $node, $keys, $args) = @_;
- unless ( ref $node eq 'HASH' ) {
- croak "prepare_metadata() requires a hashref argument to hold output\n";
- }
- croak 'Keys argument to prepare_metadata is no longer supported' if $keys;
- %{$node} = %{ $self->get_meta(%{$args}) };
- return $node;
-}
-
-sub _read_manifest {
- my ($self, $file) = @_;
- return undef unless -e $file;
-
- require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean.
- local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
- return scalar ExtUtils::Manifest::maniread($file);
-}
-
-sub find_dist_packages {
- my $self = shift;
-
- # Only packages in .pm files are candidates for inclusion here.
- # Only include things in the MANIFEST, not things in developer's
- # private stock.
-
- my $manifest = $self->_read_manifest('MANIFEST')
- or die "Can't find dist packages without a MANIFEST file\nRun 'Build manifest' to generate one\n";
-
- # Localize
- my %dist_files = map { $self->localize_file_path($_) => $_ }
- keys %$manifest;
-
- my @pm_files = grep { $_ !~ m{^t} } # skip things in t/
- grep {exists $dist_files{$_}}
- keys %{ $self->find_pm_files };
-
- return $self->find_packages_in_files(\@pm_files, \%dist_files);
-}
-
-# XXX Do not document this function; mst wrote it and now says the API is
-# stupid and needs to be fixed and it shouldn't become a public API until then
-sub find_packages_in_files {
- my ($self, $file_list, $filename_map) = @_;
-
- # First, we enumerate all packages & versions,
- # separating into primary & alternative candidates
- my( %prime, %alt );
- foreach my $file (@{$file_list}) {
- my $mapped_filename = $filename_map->{$file};
- my @path = split( /\//, $mapped_filename );
- (my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//;
-
- my $pm_info = Module::Build::ModuleInfo->new_from_file( $file );
-
- foreach my $package ( $pm_info->packages_inside ) {
- next if $package eq 'main'; # main can appear numerous times, ignore
- next if $package eq 'DB'; # special debugging package, ignore
- next if grep /^_/, split( /::/, $package ); # private package, ignore
-
- my $version = $pm_info->version( $package );
-
- if ( $package eq $prime_package ) {
- if ( exists( $prime{$package} ) ) {
- # M::B::ModuleInfo will handle this conflict
- die "Unexpected conflict in '$package'; multiple versions found.\n";
- } else {
- $prime{$package}{file} = $mapped_filename;
- $prime{$package}{version} = $version if defined( $version );
- }
- } else {
- push( @{$alt{$package}}, {
- file => $mapped_filename,
- version => $version,
- } );
- }
- }
- }
-
- # Then we iterate over all the packages found above, identifying conflicts
- # and selecting the "best" candidate for recording the file & version
- # for each package.
- foreach my $package ( keys( %alt ) ) {
- my $result = $self->_resolve_module_versions( $alt{$package} );
-
- if ( exists( $prime{$package} ) ) { # primary package selected
-
- if ( $result->{err} ) {
- # Use the selected primary package, but there are conflicting
- # errors among multiple alternative packages that need to be
- # reported
- $self->log_warn(
- "Found conflicting versions for package '$package'\n" .
- " $prime{$package}{file} ($prime{$package}{version})\n" .
- $result->{err}
- );
-
- } elsif ( defined( $result->{version} ) ) {
- # There is a primary package selected, and exactly one
- # alternative package
-
- if ( exists( $prime{$package}{version} ) &&
- defined( $prime{$package}{version} ) ) {
- # Unless the version of the primary package agrees with the
- # version of the alternative package, report a conflict
- if ( $self->compare_versions( $prime{$package}{version}, '!=',
- $result->{version} ) ) {
- $self->log_warn(
- "Found conflicting versions for package '$package'\n" .
- " $prime{$package}{file} ($prime{$package}{version})\n" .
- " $result->{file} ($result->{version})\n"
- );
- }
-
- } else {
- # The prime package selected has no version so, we choose to
- # use any alternative package that does have a version
- $prime{$package}{file} = $result->{file};
- $prime{$package}{version} = $result->{version};
- }
-
- } else {
- # no alt package found with a version, but we have a prime
- # package so we use it whether it has a version or not
- }
-
- } else { # No primary package was selected, use the best alternative
-
- if ( $result->{err} ) {
- $self->log_warn(
- "Found conflicting versions for package '$package'\n" .
- $result->{err}
- );
- }
-
- # Despite possible conflicting versions, we choose to record
- # something rather than nothing
- $prime{$package}{file} = $result->{file};
- $prime{$package}{version} = $result->{version}
- if defined( $result->{version} );
- }
- }
-
- # Normalize versions or delete them if undef/0
- for my $provides ( values %prime ) {
- if ( $provides->{version} ) {
- $provides->{version} = $self->normalize_version( $provides->{version} )
- }
- else {
- delete $provides->{version};
- }
- }
-
- return \%prime;
-}
-
-# separate out some of the conflict resolution logic from
-# $self->find_dist_packages(), above, into a helper function.
-#
-sub _resolve_module_versions {
- my $self = shift;
-
- my $packages = shift;
-
- my( $file, $version );
- my $err = '';
- foreach my $p ( @$packages ) {
- if ( defined( $p->{version} ) ) {
- if ( defined( $version ) ) {
- if ( $self->compare_versions( $version, '!=', $p->{version} ) ) {
- $err .= " $p->{file} ($p->{version})\n";
- } else {
- # same version declared multiple times, ignore
- }
- } else {
- $file = $p->{file};
- $version = $p->{version};
- }
- }
- $file ||= $p->{file} if defined( $p->{file} );
- }
-
- if ( $err ) {
- $err = " $file ($version)\n" . $err;
- }
-
- my %result = (
- file => $file,
- version => $version,
- err => $err
- );
-
- return \%result;
-}
-
-sub make_tarball {
- my ($self, $dir, $file) = @_;
- $file ||= $dir;
-
- $self->log_info("Creating $file.tar.gz\n");
-
- if ($self->{args}{tar}) {
- my $tar_flags = $self->verbose ? 'cvf' : 'cf';
- $self->do_system($self->split_like_shell($self->{args}{tar}), $tar_flags, "$file.tar", $dir);
- $self->do_system($self->split_like_shell($self->{args}{gzip}), "$file.tar") if $self->{args}{gzip};
- } else {
- eval { require Archive::Tar && Archive::Tar->VERSION(1.09); 1 }
- or die "You must install Archive::Tar 1.09+ to make a distribution tarball\n".
- "or specify a binary tar program with the '--tar' option.\n".
- "See the documentation for the 'dist' action.\n";
-
- my $files = $self->rscan_dir($dir);
-
- # Archive::Tar versions >= 1.09 use the following to enable a compatibility
- # hack so that the resulting archive is compatible with older clients.
- # If no file path is 100 chars or longer, we disable the prefix field
- # for maximum compatibility. If there are any long file paths then we
- # need the prefix field after all.
- $Archive::Tar::DO_NOT_USE_PREFIX =
- (grep { length($_) >= 100 } @$files) ? 0 : 1;
-
- my $tar = Archive::Tar->new;
- $tar->add_files(@$files);
- for my $f ($tar->get_files) {
- $f->mode($f->mode & ~022); # chmod go-w
- }
- $tar->write("$file.tar.gz", 1);
- }
-}
-
-sub install_path {
- my $self = shift;
- my( $type, $value ) = ( @_, '<empty>' );
-
- Carp::croak( 'Type argument missing' )
- unless defined( $type );
-
- my $map = $self->{properties}{install_path};
- return $map unless @_;
-
- # delete existing value if $value is literal undef()
- unless ( defined( $value ) ) {
- delete( $map->{$type} );
- return undef;
- }
-
- # return existing value if no new $value is given
- if ( $value eq '<empty>' ) {
- return undef unless exists $map->{$type};
- return $map->{$type};
- }
-
- # set value if $value is a valid relative path
- return $map->{$type} = $value;
-}
-
-sub install_sets {
- # Usage: install_sets('site'), install_sets('site', 'lib'),
- # or install_sets('site', 'lib' => $value);
- my ($self, $dirs, $key, $value) = @_;
- $dirs = $self->installdirs unless defined $dirs;
- # update property before merging with defaults
- if ( @_ == 4 && defined $dirs && defined $key) {
- # $value can be undef; will mask default
- $self->{properties}{install_sets}{$dirs}{$key} = $value;
- }
- my $map = { $self->_merge_arglist(
- $self->{properties}{install_sets},
- $self->_default_install_paths->{install_sets}
- )};
- if ( defined $dirs && defined $key ) {
- return $map->{$dirs}{$key};
- }
- elsif ( defined $dirs ) {
- return $map->{$dirs};
- }
- else {
- croak "Can't determine installdirs for install_sets()";
- }
-}
-
-sub original_prefix {
- # Usage: original_prefix(), original_prefix('lib'),
- # or original_prefix('lib' => $value);
- my ($self, $key, $value) = @_;
- # update property before merging with defaults
- if ( @_ == 3 && defined $key) {
- # $value can be undef; will mask default
- $self->{properties}{original_prefix}{$key} = $value;
- }
- my $map = { $self->_merge_arglist(
- $self->{properties}{original_prefix},
- $self->_default_install_paths->{original_prefix}
- )};
- return $map unless defined $key;
- return $map->{$key}
-}
-
-sub install_base_relpaths {
- # Usage: install_base_relpaths(), install_base_relpaths('lib'),
- # or install_base_relpaths('lib' => $value);
- my $self = shift;
- if ( @_ > 1 ) { # change values before merge
- $self->_set_relpaths($self->{properties}{install_base_relpaths}, @_);
- }
- my $map = { $self->_merge_arglist(
- $self->{properties}{install_base_relpaths},
- $self->_default_install_paths->{install_base_relpaths}
- )};
- return $map unless @_;
- my $relpath = $map->{$_[0]};
- return defined $relpath ? File::Spec->catdir( @$relpath ) : undef;
-}
-
-# Defaults to use in case the config install paths cannot be prefixified.
-sub prefix_relpaths {
- # Usage: prefix_relpaths('site'), prefix_relpaths('site', 'lib'),
- # or prefix_relpaths('site', 'lib' => $value);
- my $self = shift;
- my $installdirs = shift || $self->installdirs
- or croak "Can't determine installdirs for prefix_relpaths()";
- if ( @_ > 1 ) { # change values before merge
- $self->{properties}{prefix_relpaths}{$installdirs} ||= {};
- $self->_set_relpaths($self->{properties}{prefix_relpaths}{$installdirs}, @_);
- }
- my $map = {$self->_merge_arglist(
- $self->{properties}{prefix_relpaths}{$installdirs},
- $self->_default_install_paths->{prefix_relpaths}{$installdirs}
- )};
- return $map unless @_;
- my $relpath = $map->{$_[0]};
- return defined $relpath ? File::Spec->catdir( @$relpath ) : undef;
-}
-
-sub _set_relpaths {
- my $self = shift;
- my( $map, $type, $value ) = @_;
-
- Carp::croak( 'Type argument missing' )
- unless defined( $type );
-
- # set undef if $value is literal undef()
- if ( ! defined( $value ) ) {
- $map->{$type} = undef;
- return;
- }
- # set value if $value is a valid relative path
- else {
- Carp::croak( "Value must be a relative path" )
- if File::Spec::Unix->file_name_is_absolute($value);
-
- my @value = split( /\//, $value );
- $map->{$type} = \@value;
- }
-}
-
-# Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX
-sub prefix_relative {
- my ($self, $type) = @_;
- my $installdirs = $self->installdirs;
-
- my $relpath = $self->install_sets($installdirs)->{$type};
-
- return $self->_prefixify($relpath,
- $self->original_prefix($installdirs),
- $type,
- );
-}
-
-# Translated from ExtUtils::MM_Unix::prefixify()
-sub _prefixify {
- my($self, $path, $sprefix, $type) = @_;
-
- my $rprefix = $self->prefix;
- $rprefix .= '/' if $sprefix =~ m|/$|;
-
- $self->log_verbose(" prefixify $path from $sprefix to $rprefix\n")
- if defined( $path ) && length( $path );
-
- if( !defined( $path ) || ( length( $path ) == 0 ) ) {
- $self->log_verbose(" no path to prefixify, falling back to default.\n");
- return $self->_prefixify_default( $type, $rprefix );
- } elsif( !File::Spec->file_name_is_absolute($path) ) {
- $self->log_verbose(" path is relative, not prefixifying.\n");
- } elsif( $path !~ s{^\Q$sprefix\E\b}{}s ) {
- $self->log_verbose(" cannot prefixify, falling back to default.\n");
- return $self->_prefixify_default( $type, $rprefix );
- }
-
- $self->log_verbose(" now $path in $rprefix\n");
-
- return $path;
-}
-
-sub _prefixify_default {
- my $self = shift;
- my $type = shift;
- my $rprefix = shift;
-
- my $default = $self->prefix_relpaths($self->installdirs, $type);
- if( !$default ) {
- $self->log_verbose(" no default install location for type '$type', using prefix '$rprefix'.\n");
- return $rprefix;
- } else {
- return $default;
- }
-}
-
-sub install_destination {
- my ($self, $type) = @_;
-
- return $self->install_path($type) if $self->install_path($type);
-
- if ( $self->install_base ) {
- my $relpath = $self->install_base_relpaths($type);
- return $relpath ? File::Spec->catdir($self->install_base, $relpath) : undef;
- }
-
- if ( $self->prefix ) {
- my $relpath = $self->prefix_relative($type);
- return $relpath ? File::Spec->catdir($self->prefix, $relpath) : undef;
- }
-
- return $self->install_sets($self->installdirs)->{$type};
-}
-
-sub install_types {
- my $self = shift;
-
- my %types;
- if ( $self->install_base ) {
- %types = %{$self->install_base_relpaths};
- } elsif ( $self->prefix ) {
- %types = %{$self->prefix_relpaths};
- } else {
- %types = %{$self->install_sets($self->installdirs)};
- }
-
- %types = (%types, %{$self->install_path});
-
- return sort keys %types;
-}
-
-sub install_map {
- my ($self, $blib) = @_;
- $blib ||= $self->blib;
-
- my( %map, @skipping );
- foreach my $type ($self->install_types) {
- my $localdir = File::Spec->catdir( $blib, $type );
- next unless -e $localdir;
-
- # the line "...next if (($type eq 'bindoc'..." was one of many changes introduced for
- # improving HTML generation on ActivePerl, see https://rt.cpan.org/Public/Bug/Display.html?id=53478
- # Most changes were ok, but this particular line caused test failures in t/manifypods.t on windows,
- # therefore it is commented out.
-
- # ********* next if (($type eq 'bindoc' || $type eq 'libdoc') && not $self->is_unixish);
-
- if (my $dest = $self->install_destination($type)) {
- $map{$localdir} = $dest;
- } else {
- push( @skipping, $type );
- }
- }
-
- $self->log_warn(
- "WARNING: Can't figure out install path for types: @skipping\n" .
- "Files will not be installed.\n"
- ) if @skipping;
-
- # Write the packlist into the same place as ExtUtils::MakeMaker.
- if ($self->create_packlist and my $module_name = $self->module_name) {
- my $archdir = $self->install_destination('arch');
- my @ext = split /::/, $module_name;
- $map{write} = File::Spec->catfile($archdir, 'auto', @ext, '.packlist');
- }
-
- # Handle destdir
- if (length(my $destdir = $self->destdir || '')) {
- foreach (keys %map) {
- # Need to remove volume from $map{$_} using splitpath, or else
- # we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
- # VMS will always have the file separate than the path.
- my ($volume, $path, $file) = File::Spec->splitpath( $map{$_}, 0 );
-
- # catdir needs a list of directories, or it will create something
- # crazy like volume:[Foo.Bar.volume.Baz.Quux]
- my @dirs = File::Spec->splitdir($path);
-
- # First merge the directories
- $path = File::Spec->catdir($destdir, @dirs);
-
- # Then put the file back on if there is one.
- if ($file ne '') {
- $map{$_} = File::Spec->catfile($path, $file)
- } else {
- $map{$_} = $path;
- }
- }
- }
-
- $map{read} = ''; # To keep ExtUtils::Install quiet
-
- return \%map;
-}
-
-sub depends_on {
- my $self = shift;
- foreach my $action (@_) {
- $self->_call_action($action);
- }
-}
-
-sub rscan_dir {
- my ($self, $dir, $pattern) = @_;
- my @result;
- local $_; # find() can overwrite $_, so protect ourselves
- my $subr = !$pattern ? sub {push @result, $File::Find::name} :
- !ref($pattern) || (ref $pattern eq 'Regexp') ? sub {push @result, $File::Find::name if /$pattern/} :
- ref($pattern) eq 'CODE' ? sub {push @result, $File::Find::name if $pattern->()} :
- die "Unknown pattern type";
-
- File::Find::find({wanted => $subr, no_chdir => 1}, $dir);
- return \@result;
-}
-
-sub delete_filetree {
- my $self = shift;
- my $deleted = 0;
- foreach (@_) {
- next unless -e $_;
- $self->log_verbose("Deleting $_\n");
- File::Path::rmtree($_, 0, 0);
- die "Couldn't remove '$_': $!\n" if -e $_;
- $deleted++;
- }
- return $deleted;
-}
-
-sub autosplit_file {
- my ($self, $file, $to) = @_;
- require AutoSplit;
- my $dir = File::Spec->catdir($to, 'lib', 'auto');
- AutoSplit::autosplit($file, $dir);
-}
-
-sub cbuilder {
- # Returns a CBuilder object
-
- my $self = shift;
- my $s = $self->{stash};
- return $s->{_cbuilder} if $s->{_cbuilder};
-
- require ExtUtils::CBuilder;
- return $s->{_cbuilder} = ExtUtils::CBuilder->new(
- config => $self->config,
- ($self->quiet ? (quiet => 1 ) : ()),
- );
-}
-
-sub have_c_compiler {
- my ($self) = @_;
-
- my $p = $self->{properties};
- return $p->{_have_c_compiler} if defined $p->{_have_c_compiler};
-
- $self->log_verbose("Checking if compiler tools configured... ");
- my $b = $self->cbuilder;
- my $have = $b && eval { $b->have_compiler };
- $self->log_verbose($have ? "ok.\n" : "failed.\n");
- return $p->{_have_c_compiler} = $have;
-}
-
-sub compile_c {
- my ($self, $file, %args) = @_;
-
- if ( ! $self->have_c_compiler ) {
- die "Error: no compiler detected to compile '$file'. Aborting\n";
- }
-
- my $b = $self->cbuilder;
- my $obj_file = $b->object_file($file);
- $self->add_to_cleanup($obj_file);
- return $obj_file if $self->up_to_date($file, $obj_file);
-
- $b->compile(source => $file,
- defines => $args{defines},
- object_file => $obj_file,
- include_dirs => $self->include_dirs,
- extra_compiler_flags => $self->extra_compiler_flags,
- );
-
- return $obj_file;
-}
-
-sub link_c {
- my ($self, $spec) = @_;
- my $p = $self->{properties}; # For convenience
-
- $self->add_to_cleanup($spec->{lib_file});
-
- my $objects = $p->{objects} || [];
-
- return $spec->{lib_file}
- if $self->up_to_date([$spec->{obj_file}, @$objects],
- $spec->{lib_file});
-
- my $module_name = $spec->{module_name} || $self->module_name;
-
- $self->cbuilder->link(
- module_name => $module_name,
- objects => [$spec->{obj_file}, @$objects],
- lib_file => $spec->{lib_file},
- extra_linker_flags => $p->{extra_linker_flags} );
-
- return $spec->{lib_file};
-}
-
-sub compile_xs {
- my ($self, $file, %args) = @_;
-
- $self->log_verbose("$file -> $args{outfile}\n");
-
- if (eval {require ExtUtils::ParseXS; 1}) {
-
- ExtUtils::ParseXS::process_file(
- filename => $file,
- prototypes => 0,
- output => $args{outfile},
- );
- } else {
- # Ok, I give up. Just use backticks.
-
- my $xsubpp = Module::Build::ModuleInfo->find_module_by_name('ExtUtils::xsubpp')
- or die "Can't find ExtUtils::xsubpp in INC (@INC)";
-
- my @typemaps;
- push @typemaps, Module::Build::ModuleInfo->find_module_by_name(
- 'ExtUtils::typemap', \@INC
- );
- my $lib_typemap = Module::Build::ModuleInfo->find_module_by_name(
- 'typemap', [File::Basename::dirname($file), File::Spec->rel2abs('.')]
- );
- push @typemaps, $lib_typemap if $lib_typemap;
- @typemaps = map {+'-typemap', $_} @typemaps;
-
- my $cf = $self->{config};
- my $perl = $self->{properties}{perl};
-
- my @command = ($perl, "-I".$cf->get('installarchlib'), "-I".$cf->get('installprivlib'), $xsubpp, '-noprototypes',
- @typemaps, $file);
-
- $self->log_info("@command\n");
- open(my $fh, '>', $args{outfile}) or die "Couldn't write $args{outfile}: $!";
- print {$fh} $self->_backticks(@command);
- close $fh;
- }
-}
-
-sub split_like_shell {
- my ($self, $string) = @_;
-
- return () unless defined($string);
- return @$string if UNIVERSAL::isa($string, 'ARRAY');
- $string =~ s/^\s+|\s+$//g;
- return () unless length($string);
-
- return Text::ParseWords::shellwords($string);
-}
-
-sub oneliner {
- # Returns a string that the shell can evaluate as a perl command.
- # This should be avoided whenever possible, since "the shell" really
- # means zillions of shells on zillions of platforms and it's really
- # hard to get it right all the time.
-
- # Some of this code is stolen with permission from ExtUtils::MakeMaker.
-
- my($self, $cmd, $switches, $args) = @_;
- $switches = [] unless defined $switches;
- $args = [] unless defined $args;
-
- # Strip leading and trailing newlines
- $cmd =~ s{^\n+}{};
- $cmd =~ s{\n+$}{};
-
- my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
- return $self->_quote_args($perl, @$switches, '-e', $cmd, @$args);
-}
-
-sub run_perl_script {
- my ($self, $script, $preargs, $postargs) = @_;
- foreach ($preargs, $postargs) {
- $_ = [ $self->split_like_shell($_) ] unless ref();
- }
- return $self->run_perl_command([@$preargs, $script, @$postargs]);
-}
-
-sub run_perl_command {
- # XXX Maybe we should accept @args instead of $args? Must resolve
- # this before documenting.
- my ($self, $args) = @_;
- $args = [ $self->split_like_shell($args) ] unless ref($args);
- my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
-
- # Make sure our local additions to @INC are propagated to the subprocess
- local $ENV{PERL5LIB} = join $self->config('path_sep'), $self->_added_to_INC;
-
- return $self->do_system($perl, @$args);
-}
-
-# Infer various data from the path of the input filename
-# that is needed to create output files.
-# The input filename is expected to be of the form:
-# lib/Module/Name.ext or Module/Name.ext
-sub _infer_xs_spec {
- my $self = shift;
- my $file = shift;
-
- my $cf = $self->{config};
-
- my %spec;
-
- my( $v, $d, $f ) = File::Spec->splitpath( $file );
- my @d = File::Spec->splitdir( $d );
- (my $file_base = $f) =~ s/\.[^.]+$//i;
-
- $spec{base_name} = $file_base;
-
- $spec{src_dir} = File::Spec->catpath( $v, $d, '' );
-
- # the module name
- shift( @d ) while @d && ($d[0] eq 'lib' || $d[0] eq '');
- pop( @d ) while @d && $d[-1] eq '';
- $spec{module_name} = join( '::', (@d, $file_base) );
-
- $spec{archdir} = File::Spec->catdir($self->blib, 'arch', 'auto',
- @d, $file_base);
-
- $spec{c_file} = File::Spec->catfile( $spec{src_dir},
- "${file_base}.c" );
-
- $spec{obj_file} = File::Spec->catfile( $spec{src_dir},
- "${file_base}".$cf->get('obj_ext') );
-
- require DynaLoader;
- my $modfname = defined &DynaLoader::mod2fname ? DynaLoader::mod2fname([@d, $file_base]) : $file_base;
-
- $spec{bs_file} = File::Spec->catfile($spec{archdir}, "$modfname.bs");
-
- $spec{lib_file} = File::Spec->catfile($spec{archdir}, "$modfname.".$cf->get('dlext'));
-
- return \%spec;
-}
-
-sub process_xs {
- my ($self, $file) = @_;
-
- my $spec = $self->_infer_xs_spec($file);
-
- # File name, minus the suffix
- (my $file_base = $file) =~ s/\.[^.]+$//;
-
- # .xs -> .c
- $self->add_to_cleanup($spec->{c_file});
-
- unless ($self->up_to_date($file, $spec->{c_file})) {
- $self->compile_xs($file, outfile => $spec->{c_file});
- }
-
- # .c -> .o
- my $v = $self->dist_version;
- $self->compile_c($spec->{c_file},
- defines => {VERSION => qq{"$v"}, XS_VERSION => qq{"$v"}});
-
- # archdir
- File::Path::mkpath($spec->{archdir}, 0, oct(777)) unless -d $spec->{archdir};
-
- # .xs -> .bs
- $self->add_to_cleanup($spec->{bs_file});
- unless ($self->up_to_date($file, $spec->{bs_file})) {
- require ExtUtils::Mkbootstrap;
- $self->log_info("ExtUtils::Mkbootstrap::Mkbootstrap('$spec->{bs_file}')\n");
- ExtUtils::Mkbootstrap::Mkbootstrap($spec->{bs_file}); # Original had $BSLOADLIBS - what's that?
- open(my $fh, '>>', $spec->{bs_file}); # create
- utime((time)x2, $spec->{bs_file}); # touch
- }
-
- # .o -> .(a|bundle)
- $self->link_c($spec);
-}
-
-sub do_system {
- my ($self, @cmd) = @_;
- $self->log_verbose("@cmd\n");
-
- # Some systems proliferate huge PERL5LIBs, try to ameliorate:
- my %seen;
- my $sep = $self->config('path_sep');
- local $ENV{PERL5LIB} =
- ( !exists($ENV{PERL5LIB}) ? '' :
- length($ENV{PERL5LIB}) < 500
- ? $ENV{PERL5LIB}
- : join $sep, grep { ! $seen{$_}++ and -d $_ } split($sep, $ENV{PERL5LIB})
- );
-
- my $status = system(@cmd);
- if ($status and $! =~ /Argument list too long/i) {
- my $env_entries = '';
- foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
- warn "'Argument list' was 'too long', env lengths are $env_entries";
- }
- return !$status;
-}
-
-sub copy_if_modified {
- my $self = shift;
- my %args = (@_ > 3
- ? ( @_ )
- : ( from => shift, to_dir => shift, flatten => shift )
- );
- $args{verbose} = !$self->quiet
- unless exists $args{verbose};
-
- my $file = $args{from};
- unless (defined $file and length $file) {
- die "No 'from' parameter given to copy_if_modified";
- }
-
- # makes no sense to replicate an absolute path, so assume flatten
- $args{flatten} = 1 if File::Spec->file_name_is_absolute( $file );
-
- my $to_path;
- if (defined $args{to} and length $args{to}) {
- $to_path = $args{to};
- } elsif (defined $args{to_dir} and length $args{to_dir}) {
- $to_path = File::Spec->catfile( $args{to_dir}, $args{flatten}
- ? File::Basename::basename($file)
- : $file );
- } else {
- die "No 'to' or 'to_dir' parameter given to copy_if_modified";
- }
-
- return if $self->up_to_date($file, $to_path); # Already fresh
-
- {
- local $self->{properties}{quiet} = 1;
- $self->delete_filetree($to_path); # delete destination if exists
- }
-
- # Create parent directories
- File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777));
-
- $self->log_verbose("Copying $file -> $to_path\n");
-
- if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite
- chmod 0666, $to_path;
- File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!";
- } else {
- File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
- }
-
- # mode is read-only + (executable if source is executable)
- my $mode = oct(444) | ( $self->is_executable($file) ? oct(111) : 0 );
- chmod( $mode, $to_path );
-
- return $to_path;
-}
-
-sub up_to_date {
- my ($self, $source, $derived) = @_;
- $source = [$source] unless ref $source;
- $derived = [$derived] unless ref $derived;
-
- # empty $derived means $source should always run
- return 0 if @$source && !@$derived || grep {not -e} @$derived;
-
- my $most_recent_source = time / (24*60*60);
- foreach my $file (@$source) {
- unless (-e $file) {
- $self->log_warn("Can't find source file $file for up-to-date check");
- next;
- }
- $most_recent_source = -M _ if -M _ < $most_recent_source;
- }
-
- foreach my $derived (@$derived) {
- return 0 if -M $derived > $most_recent_source;
- }
- return 1;
-}
-
-sub dir_contains {
- my ($self, $first, $second) = @_;
- # File::Spec doesn't have an easy way to check whether one directory
- # is inside another, unfortunately.
-
- ($first, $second) = map File::Spec->canonpath($_), ($first, $second);
- my @first_dirs = File::Spec->splitdir($first);
- my @second_dirs = File::Spec->splitdir($second);
-
- return 0 if @second_dirs < @first_dirs;
-
- my $is_same = ( $self->_case_tolerant
- ? sub {lc(shift()) eq lc(shift())}
- : sub {shift() eq shift()} );
-
- while (@first_dirs) {
- return 0 unless $is_same->(shift @first_dirs, shift @second_dirs);
- }
-
- return 1;
-}
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::Base - Default methods for Module::Build
-
-=head1 SYNOPSIS
-
- Please see the Module::Build documentation.
-
-=head1 DESCRIPTION
-
-The C<Module::Build::Base> module defines the core functionality of
-C<Module::Build>. Its methods may be overridden by any of the
-platform-dependent modules in the C<Module::Build::Platform::>
-namespace, but the intention here is to make this base module as
-platform-neutral as possible. Nicely enough, Perl has several core
-tools available in the C<File::> namespace for doing this, so the task
-isn't very difficult.
-
-Please see the C<Module::Build> documentation for more details.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2001-2006 Ken Williams. All rights reserved.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3)
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Module::Build::Bundling - How to bundle Module::Build with a distribution
-
-=head1 SYNOPSIS
-
- # Build.PL
- use inc::latest 'Module::Build';
-
- Module::Build->new(
- module_name => 'Foo::Bar',
- license => 'perl',
- )->create_build_script;
-
-=head1 DESCRIPTION
-
-B<WARNING -- THIS IS AN EXPERIMENTAL FEATURE>
-
-In order to install a distribution using Module::Build, users must
-have Module::Build available on their systems. There are two ways
-to do this. The first way is to include Module::Build in the
-C<configure_requires> metadata field. This field is supported by
-recent versions L<CPAN> and L<CPANPLUS> and is a standard feature
-in the Perl core as of Perl 5.10.1. Module::Build now adds itself
-to C<configure_requires> by default.
-
-The second way supports older Perls that have not upgraded CPAN or
-CPANPLUS and involves bundling an entire copy of Module::Build
-into the distribution's C<inc/> directory. This is the same approach
-used by L<Module::Install>, a modern wrapper around ExtUtils::MakeMaker
-for Makefile.PL based distributions.
-
-The "trick" to making this work for Module::Build is making sure the
-highest version Module::Build is used, whether this is in C<inc/> or
-already installed on the user's system. This ensures that all necessary
-features are available as well as any new bug fixes. This is done using
-the new L<inc::latest> module.
-
-A "normal" Build.PL looks like this (with only the minimum required
-fields):
-
- use Module::Build;
-
- Module::Build->new(
- module_name => 'Foo::Bar',
- license => 'perl',
- )->create_build_script;
-
-A "bundling" Build.PL replaces the initial "use" line with a nearly
-transparent replacement:
-
- use inc::latest 'Module::Build';
-
- Module::Build->new(
- module_name => 'Foo::Bar',
- license => 'perl',
- )->create_build_script;
-
-For I<authors>, when "Build dist" is run, Module::Build will be
-automatically bundled into C<inc> according to the rules for
-L<inc::latest>.
-
-For I<users>, inc::latest will load the latest Module::Build, whether
-installed or bundled in C<inc/>.
-
-=head1 BUNDLING OTHER CONFIGURATION DEPENDENCIES
-
-The same approach works for other configuration dependencies -- modules
-that I<must> be available for Build.PL to run. All other dependencies can
-be specified as usual in the Build.PL and CPAN or CPANPLUS will install
-them after Build.PL finishes.
-
-For example, to bundle the L<Devel::AssertOS::Unix> module (which ensures a
-"Unix-like" operating system), one could do this:
-
- use inc::latest 'Devel::AssertOS::Unix';
- use inc::latest 'Module::Build';
-
- Module::Build->new(
- module_name => 'Foo::Bar',
- license => 'perl',
- )->create_build_script;
-
-The C<inc::latest> module creates bundled directories based on the packlist
-file of an installed distribution. Even though C<inc::latest> takes module
-name arguments, it is better to think of it as bundling and making
-available entire I<distributions>. When a module is loaded through
-C<inc::latest>, it looks in all bundled distributions in C<inc/> for a
-newer module than can be found in the existing C<@INC> array.
-
-Thus, the module-name provided should usually be the "top-level" module
-name of a distribution, though this is not strictly required. For example,
-L<Module::Build> has a number of heuristics to map module names to
-packlists, allowing users to do things like this:
-
- use inc::latest 'Devel::AssertOS::Unix';
-
-even though Devel::AssertOS::Unix is contained within the Devel-CheckOS
-distribution.
-
-At the current time, packlists are required. Thus, bundling dual-core
-modules, I<including Module::Build>, may require a 'forced install' over
-versions in the latest version of perl in order to create the necessary
-packlist for bundling. This limitation will hopefully be addressed in a
-future version of Module::Build.
-
-=head2 WARNING -- How to Manage Dependency Chains
-
-Before bundling a distribution you must ensure that all prerequisites are
-also bundled and load in the correct order. For Module::Build itself, this
-should not be necessary, but it is necessary for any other distribution.
-(A future release of Module::Build will hopefully address this deficiency.)
-
-For example, if you need C<Wibble>, but C<Wibble> depends on C<Wobble>,
-your Build.PL might look like this:
-
- use inc::latest 'Wobble';
- use inc::latest 'Wibble';
- use inc::latest 'Module::Build';
-
- Module::Build->new(
- module_name => 'Foo::Bar',
- license => 'perl',
- )->create_build_script;
-
-Authors are strongly suggested to limit the bundling of additional
-dependencies if at all possible and to carefully test their distribution
-tarballs on older versions of Perl before uploading to CPAN.
-
-=head1 AUTHOR
-
-David Golden <dagolden@cpan.org>
-
-Development questions, bug reports, and patches should be sent to the
-Module-Build mailing list at <module-build@perl.org>.
-
-Bug reports are also welcome at
-<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build>.
-
-=head1 SEE ALSO
-
-perl(1), L<inc::latest>, L<Module::Build>(3), L<Module::Build::API>(3),
-L<Module::Build::Cookbook>(3),
-
-=cut
-
-# vim: tw=75
+++ /dev/null
-package Module::Build::Compat;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-
-use File::Basename ();
-use File::Spec;
-use Config;
-use Module::Build;
-use Module::Build::ModuleInfo;
-use Module::Build::Version;
-use Data::Dumper;
-
-my %convert_installdirs = (
- PERL => 'core',
- SITE => 'site',
- VENDOR => 'vendor',
-);
-
-my %makefile_to_build =
- (
- TEST_VERBOSE => 'verbose',
- VERBINST => 'verbose',
- INC => sub { map {(extra_compiler_flags => $_)} Module::Build->split_like_shell(shift) },
- POLLUTE => sub { (extra_compiler_flags => '-DPERL_POLLUTE') },
- INSTALLDIRS => sub { (installdirs => $convert_installdirs{uc shift()}) },
- LIB => sub {
- my $lib = shift;
- my %config = (
- installprivlib => $lib,
- installsitelib => $lib,
- installarchlib => "$lib/$Config{archname}",
- installsitearch => "$lib/$Config{archname}"
- );
- return map { (config => "$_=$config{$_}") } keys %config;
- },
-
- # Convert INSTALLVENDORLIB and friends.
- (
- map {
- my $name = $_;
- $name => sub {
- my @ret = (config => lc($name) . "=" . shift );
- print STDERR "# Converted to @ret\n";
-
- return @ret;
- }
- } qw(
- INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
- INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
- INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
- INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
- INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR
- INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR
- )
- ),
-
- # Some names they have in common
- map {$_, lc($_)} qw(DESTDIR PREFIX INSTALL_BASE UNINST),
- );
-
-my %macro_to_build = %makefile_to_build;
-# "LIB=foo make" is not the same as "perl Makefile.PL LIB=foo"
-delete $macro_to_build{LIB};
-
-sub _merge_prereq {
- my ($req, $breq) = @_;
- $req ||= {};
- $breq ||= {};
-
- # validate formats
- for my $p ( $req, $breq ) {
- for my $k (keys %$p) {
- next if $k eq 'perl';
-
- my $v_obj = eval { Module::Build::Version->new($p->{$k}) };
- if ( ! defined $v_obj ) {
- die "A prereq of the form '$p->{$k}' for '$k' is not supported by Module::Build::Compat ( use a simpler version like '0.05' or 'v1.4.25' )\n";
- }
-
- # It seems like a lot of people trip over "0.1.2" stuff, so we help them here...
- if ( $v_obj->is_qv ) {
- my $proper_ver = $v_obj->numify;
- warn "Dotted-decimal prereq '$p->{$k}' for '$k' is not portable - converting it to '$proper_ver'\n";
- $p->{$k} = $proper_ver;
- }
- }
- }
- # merge
- my $merge = { %$req };
- for my $k ( keys %$breq ) {
- my $v1 = $merge->{$k} || 0;
- my $v2 = $breq->{$k};
- $merge->{$k} = $v1 > $v2 ? $v1 : $v2;
- }
- return %$merge;
-}
-
-
-sub create_makefile_pl {
- my ($package, $type, $build, %args) = @_;
-
- die "Don't know how to build Makefile.PL of type '$type'"
- unless $type =~ /^(small|passthrough|traditional)$/;
-
- if ($type eq 'passthrough') {
- $build->log_warn(<<"HERE");
-
-IMPORTANT NOTE: The '$type' style of Makefile.PL is deprecated and
-may be removed in a future version of Module::Build in favor of the
-'configure_requires' property. See Module::Build::Compat
-documentation for details.
-
-HERE
- }
-
- my $fh;
- if ($args{fh}) {
- $fh = $args{fh};
- } else {
- $args{file} ||= 'Makefile.PL';
- local $build->{properties}{quiet} = 1;
- $build->delete_filetree($args{file});
- open($fh, '>', "$args{file}") or die "Can't write $args{file}: $!";
- }
-
- print {$fh} "# Note: this file was auto-generated by ", __PACKAGE__, " version $VERSION\n";
-
- # Minimum perl version should be specified as "require 5.XXXXXX" in
- # Makefile.PL
- my $requires = $build->requires;
- if ( my $minimum_perl = $requires->{perl} ) {
- my $min_ver = Module::Build::Version->new($minimum_perl)->numify;
- print {$fh} "require $min_ver;\n";
- }
-
- # If a *bundled* custom subclass is being used, make sure we add its
- # directory to @INC. Also, lib.pm always needs paths in Unix format.
- my $subclass_load = '';
- if (ref($build) ne "Module::Build") {
- my $subclass_dir = $package->subclass_dir($build);
-
- if (File::Spec->file_name_is_absolute($subclass_dir)) {
- my $base_dir = $build->base_dir;
-
- if ($build->dir_contains($base_dir, $subclass_dir)) {
- $subclass_dir = File::Spec->abs2rel($subclass_dir, $base_dir);
- $subclass_dir = $package->unixify_dir($subclass_dir);
- $subclass_load = "use lib '$subclass_dir';";
- }
- # Otherwise, leave it the empty string
-
- } else {
- $subclass_dir = $package->unixify_dir($subclass_dir);
- $subclass_load = "use lib '$subclass_dir';";
- }
- }
-
- if ($type eq 'small') {
- printf {$fh} <<'EOF', $subclass_load, ref($build), ref($build);
- use Module::Build::Compat 0.02;
- %s
- Module::Build::Compat->run_build_pl(args => \@ARGV);
- require %s;
- Module::Build::Compat->write_makefile(build_class => '%s');
-EOF
-
- } elsif ($type eq 'passthrough') {
- printf {$fh} <<'EOF', $subclass_load, ref($build), ref($build);
-
- unless (eval "use Module::Build::Compat 0.02; 1" ) {
- print "This module requires Module::Build to install itself.\n";
-
- require ExtUtils::MakeMaker;
- my $yn = ExtUtils::MakeMaker::prompt
- (' Install Module::Build now from CPAN?', 'y');
-
- unless ($yn =~ /^y/i) {
- die " *** Cannot install without Module::Build. Exiting ...\n";
- }
-
- require Cwd;
- require File::Spec;
- require CPAN;
-
- # Save this 'cause CPAN will chdir all over the place.
- my $cwd = Cwd::cwd();
-
- CPAN::Shell->install('Module::Build::Compat');
- CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate
- or die "Couldn't install Module::Build, giving up.\n";
-
- chdir $cwd or die "Cannot chdir() back to $cwd: $!";
- }
- eval "use Module::Build::Compat 0.02; 1" or die $@;
- %s
- Module::Build::Compat->run_build_pl(args => \@ARGV);
- my $build_script = 'Build';
- $build_script .= '.com' if $^O eq 'VMS';
- exit(0) unless(-e $build_script); # cpantesters convention
- require %s;
- Module::Build::Compat->write_makefile(build_class => '%s');
-EOF
-
- } elsif ($type eq 'traditional') {
-
- my (%MM_Args, %prereq);
- if (eval "use Tie::IxHash 1.2; 1") {
- tie %MM_Args, 'Tie::IxHash'; # Don't care if it fails here
- tie %prereq, 'Tie::IxHash'; # Don't care if it fails here
- }
-
- my %name = ($build->module_name
- ? (NAME => $build->module_name)
- : (DISTNAME => $build->dist_name));
-
- my %version = ($build->dist_version_from
- ? (VERSION_FROM => $build->dist_version_from)
- : (VERSION => $build->dist_version)
- );
- %MM_Args = (%name, %version);
-
- %prereq = _merge_prereq( $build->requires, $build->build_requires );
- %prereq = map {$_, $prereq{$_}} sort keys %prereq;
-
- delete $prereq{perl};
- $MM_Args{PREREQ_PM} = \%prereq;
-
- $MM_Args{INSTALLDIRS} = $build->installdirs eq 'core' ? 'perl' : $build->installdirs;
-
- $MM_Args{EXE_FILES} = [ sort keys %{$build->script_files} ] if $build->script_files;
-
- $MM_Args{PL_FILES} = $build->PL_files || {};
-
- if ($build->recursive_test_files) {
- $MM_Args{test} = { TESTS => join q{ }, $package->_test_globs($build) };
- }
-
- local $Data::Dumper::Terse = 1;
- my $args = Data::Dumper::Dumper(\%MM_Args);
- $args =~ s/\{(.*)\}/($1)/s;
-
- print $fh <<"EOF";
-use ExtUtils::MakeMaker;
-WriteMakefile
-$args;
-EOF
- }
-}
-
-sub _test_globs {
- my ($self, $build) = @_;
-
- return map { File::Spec->catfile($_, '*.t') }
- @{$build->rscan_dir('t', sub { -d $File::Find::name })};
-}
-
-sub subclass_dir {
- my ($self, $build) = @_;
-
- return (Module::Build::ModuleInfo->find_module_dir_by_name(ref $build)
- || File::Spec->catdir($build->config_dir, 'lib'));
-}
-
-sub unixify_dir {
- my ($self, $path) = @_;
- return join '/', File::Spec->splitdir($path);
-}
-
-sub makefile_to_build_args {
- my $class = shift;
- my @out;
- foreach my $arg (@_) {
- next if $arg eq '';
-
- my ($key, $val) = ($arg =~ /^(\w+)=(.+)/ ? ($1, $2) :
- die "Malformed argument '$arg'");
-
- # Do tilde-expansion if it looks like a tilde prefixed path
- ( $val ) = Module::Build->_detildefy( $val ) if $val =~ /^~/;
-
- if (exists $makefile_to_build{$key}) {
- my $trans = $makefile_to_build{$key};
- push @out, $class->_argvify( ref($trans) ? $trans->($val) : ($trans => $val) );
- } elsif (exists $Config{lc($key)}) {
- push @out, $class->_argvify( config => lc($key) . "=$val" );
- } else {
- # Assume M::B can handle it in lowercase form
- push @out, $class->_argvify("\L$key" => $val);
- }
- }
- return @out;
-}
-
-sub _argvify {
- my ($self, @pairs) = @_;
- my @out;
- while (@pairs) {
- my ($k, $v) = splice @pairs, 0, 2;
- push @out, ("--$k", $v);
- }
- return @out;
-}
-
-sub makefile_to_build_macros {
- my @out;
- my %config; # must accumulate and return as a hashref
- while (my ($macro, $trans) = each %macro_to_build) {
- # On some platforms (e.g. Cygwin with 'make'), the mere presence
- # of "EXPORT: FOO" in the Makefile will make $ENV{FOO} defined.
- # Therefore we check length() too.
- next unless exists $ENV{$macro} && length $ENV{$macro};
- my $val = $ENV{$macro};
- my @args = ref($trans) ? $trans->($val) : ($trans => $val);
- while (@args) {
- my ($k, $v) = splice(@args, 0, 2);
- if ( $k eq 'config' ) {
- if ( $v =~ /^([^=]+)=(.*)$/ ) {
- $config{$1} = $2;
- }
- else {
- warn "Couldn't parse config '$v'\n";
- }
- }
- else {
- push @out, ($k => $v);
- }
- }
- }
- push @out, (config => \%config) if %config;
- return @out;
-}
-
-sub run_build_pl {
- my ($pack, %in) = @_;
- $in{script} ||= 'Build.PL';
- my @args = $in{args} ? $pack->makefile_to_build_args(@{$in{args}}) : ();
- print "# running $in{script} @args\n";
- Module::Build->run_perl_script($in{script}, [], \@args) or die "Couldn't run $in{script}: $!";
-}
-
-sub fake_makefile {
- my ($self, %args) = @_;
- unless (exists $args{build_class}) {
- warn "Unknown 'build_class', defaulting to 'Module::Build'\n";
- $args{build_class} = 'Module::Build';
- }
- my $class = $args{build_class};
-
- my $perl = $class->find_perl_interpreter;
-
- # VMS MMS/MMK need to use MCR to run the Perl image.
- $perl = 'MCR ' . $perl if $self->_is_vms_mms;
-
- my $noop = ($class->is_windowsish ? 'rem>nul' :
- $self->_is_vms_mms ? 'Continue' :
- 'true');
-
- my $filetype = $class->is_vmsish ? '.COM' : '';
-
- my $Build = 'Build' . $filetype . ' --makefile_env_macros 1';
- my $unlink = $class->oneliner('1 while unlink $ARGV[0]', [], [$args{makefile}]);
- $unlink =~ s/\$/\$\$/g unless $class->is_vmsish;
-
- my $maketext = ($^O eq 'os2' ? "SHELL = sh\n\n" : '');
-
- $maketext .= <<"EOF";
-all : force_do_it
- $perl $Build
-realclean : force_do_it
- $perl $Build realclean
- $unlink
-distclean : force_do_it
- $perl $Build distclean
- $unlink
-
-
-force_do_it :
- @ $noop
-EOF
-
- foreach my $action ($class->known_actions) {
- next if $action =~ /^(all|distclean|realclean|force_do_it)$/; # Don't double-define
- $maketext .= <<"EOF";
-$action : force_do_it
- $perl $Build $action
-EOF
- }
-
- if ($self->_is_vms_mms) {
- # Roll our own .EXPORT as MMS/MMK don't honor that directive.
- $maketext .= "\n.FIRST\n\t\@ $noop\n";
- for my $macro (keys %macro_to_build) {
- $maketext .= ".IFDEF $macro\n\tDEFINE $macro \"\$($macro)\"\n.ENDIF\n";
- }
- $maketext .= "\n";
- }
- else {
- $maketext .= "\n.EXPORT : " . join(' ', keys %macro_to_build) . "\n\n";
- }
-
- return $maketext;
-}
-
-sub fake_prereqs {
- my $file = File::Spec->catfile('_build', 'prereqs');
- open(my $fh, '<', "$file") or die "Can't read $file: $!";
- my $prereqs = eval do {local $/; <$fh>};
- close $fh;
-
- my %merged = _merge_prereq( $prereqs->{requires}, $prereqs->{build_requires} );
- my @prereq;
- foreach (sort keys %merged) {
- next if $_ eq 'perl';
- push @prereq, "$_=>q[$merged{$_}]";
- }
- return unless @prereq;
- return "# PREREQ_PM => { " . join(", ", @prereq) . " }\n\n";
-}
-
-
-sub write_makefile {
- my ($pack, %in) = @_;
-
- unless (exists $in{build_class}) {
- warn "Unknown 'build_class', defaulting to 'Module::Build'\n";
- $in{build_class} = 'Module::Build';
- }
- my $class = $in{build_class};
- $in{makefile} ||= $pack->_is_vms_mms ? 'Descrip.MMS' : 'Makefile';
-
- open MAKE, "> $in{makefile}" or die "Cannot write $in{makefile}: $!";
- print MAKE $pack->fake_prereqs;
- print MAKE $pack->fake_makefile(%in);
- close MAKE;
-}
-
-sub _is_vms_mms {
- return Module::Build->is_vmsish && ($Config{make} =~ m/MM[SK]/i);
-}
-
-1;
-__END__
-
-=for :stopwords passthrough
-
-=head1 NAME
-
-Module::Build::Compat - Compatibility with ExtUtils::MakeMaker
-
-=head1 SYNOPSIS
-
- # In a Build.PL :
- use Module::Build;
- my $build = Module::Build->new
- ( module_name => 'Foo::Bar',
- license => 'perl',
- create_makefile_pl => 'traditional' );
- ...
-
-
-=head1 DESCRIPTION
-
-Because C<ExtUtils::MakeMaker> has been the standard way to distribute
-modules for a long time, many tools (CPAN.pm, or your system
-administrator) may expect to find a working F<Makefile.PL> in every
-distribution they download from CPAN. If you want to throw them a
-bone, you can use C<Module::Build::Compat> to automatically generate a
-F<Makefile.PL> for you, in one of several different styles.
-
-C<Module::Build::Compat> also provides some code that helps out the
-F<Makefile.PL> at runtime.
-
-
-=head1 METHODS
-
-=over 4
-
-=item create_makefile_pl($style, $build)
-
-Creates a F<Makefile.PL> in the current directory in one of several
-styles, based on the supplied C<Module::Build> object C<$build>. This is
-typically controlled by passing the desired style as the
-C<create_makefile_pl> parameter to C<Module::Build>'s C<new()> method;
-the F<Makefile.PL> will then be automatically created during the
-C<distdir> action.
-
-The currently supported styles are:
-
-=over 4
-
-=item traditional
-
-A F<Makefile.PL> will be created in the "traditional" style, i.e. it will
-use C<ExtUtils::MakeMaker> and won't rely on C<Module::Build> at all.
-In order to create the F<Makefile.PL>, we'll include the C<requires> and
-C<build_requires> dependencies as the C<PREREQ_PM> parameter.
-
-You don't want to use this style if during the C<perl Build.PL> stage
-you ask the user questions, or do some auto-sensing about the user's
-environment, or if you subclass C<Module::Build> to do some
-customization, because the vanilla F<Makefile.PL> won't do any of that.
-
-=item small
-
-A small F<Makefile.PL> will be created that passes all functionality
-through to the F<Build.PL> script in the same directory. The user must
-already have C<Module::Build> installed in order to use this, or else
-they'll get a module-not-found error.
-
-=item passthrough (DEPRECATED)
-
-This is just like the C<small> option above, but if C<Module::Build> is
-not already installed on the user's system, the script will offer to
-use C<CPAN.pm> to download it and install it before continuing with
-the build.
-
-This option has been deprecated and may be removed in a future version
-of Module::Build. Modern CPAN.pm and CPANPLUS will recognize the
-C<configure_requires> metadata property and install Module::Build before
-running Build.PL if Module::Build is listed and Module::Build now
-adds itself to configure_requires by default.
-
-Perl 5.10.1 includes C<configure_requires> support. In the future, when
-C<configure_requires> support is deemed sufficiently widespread, the
-C<passthrough> style will be removed.
-
-=back
-
-=item run_build_pl(args => \@ARGV)
-
-This method runs the F<Build.PL> script, passing it any arguments the
-user may have supplied to the C<perl Makefile.PL> command. Because
-C<ExtUtils::MakeMaker> and C<Module::Build> accept different arguments, this
-method also performs some translation between the two.
-
-C<run_build_pl()> accepts the following named parameters:
-
-=over 4
-
-=item args
-
-The C<args> parameter specifies the parameters that would usually
-appear on the command line of the C<perl Makefile.PL> command -
-typically you'll just pass a reference to C<@ARGV>.
-
-=item script
-
-This is the filename of the script to run - it defaults to C<Build.PL>.
-
-=back
-
-=item write_makefile()
-
-This method writes a 'dummy' F<Makefile> that will pass all commands
-through to the corresponding C<Module::Build> actions.
-
-C<write_makefile()> accepts the following named parameters:
-
-=over 4
-
-=item makefile
-
-The name of the file to write - defaults to the string C<Makefile>.
-
-=back
-
-=back
-
-
-=head1 SCENARIOS
-
-So, some common scenarios are:
-
-=over 4
-
-=item 1.
-
-Just include a F<Build.PL> script (without a F<Makefile.PL>
-script), and give installation directions in a F<README> or F<INSTALL>
-document explaining how to install the module. In particular, explain
-that the user must install C<Module::Build> before installing your
-module.
-
-Note that if you do this, you may make things easier for yourself, but
-harder for people with older versions of CPAN or CPANPLUS on their
-system, because those tools generally only understand the
-F<Makefile.PL>/C<ExtUtils::MakeMaker> way of doing things.
-
-=item 2.
-
-Include a F<Build.PL> script and a "traditional" F<Makefile.PL>,
-created either manually or with C<create_makefile_pl()>. Users won't
-ever have to install C<Module::Build> if they use the F<Makefile.PL>, but
-they won't get to take advantage of C<Module::Build>'s extra features
-either.
-
-For good measure, of course, test both the F<Makefile.PL> and the
-F<Build.PL> before shipping.
-
-=item 3.
-
-Include a F<Build.PL> script and a "pass-through" F<Makefile.PL>
-built using C<Module::Build::Compat>. This will mean that people can
-continue to use the "old" installation commands, and they may never
-notice that it's actually doing something else behind the scenes. It
-will also mean that your installation process is compatible with older
-versions of tools like CPAN and CPANPLUS.
-
-=back
-
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-
-=head1 COPYRIGHT
-
-Copyright (c) 2001-2006 Ken Williams. All rights reserved.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-
-=head1 SEE ALSO
-
-L<Module::Build>(3), L<ExtUtils::MakeMaker>(3)
-
-
-=cut
+++ /dev/null
-package Module::Build::Config;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Config;
-
-sub new {
- my ($pack, %args) = @_;
- return bless {
- stack => {},
- values => $args{values} || {},
- }, $pack;
-}
-
-sub get {
- my ($self, $key) = @_;
- return $self->{values}{$key} if ref($self) && exists $self->{values}{$key};
- return $Config{$key};
-}
-
-sub set {
- my ($self, $key, $val) = @_;
- $self->{values}{$key} = $val;
-}
-
-sub push {
- my ($self, $key, $val) = @_;
- push @{$self->{stack}{$key}}, $self->{values}{$key}
- if exists $self->{values}{$key};
- $self->{values}{$key} = $val;
-}
-
-sub pop {
- my ($self, $key) = @_;
-
- my $val = delete $self->{values}{$key};
- if ( exists $self->{stack}{$key} ) {
- $self->{values}{$key} = pop @{$self->{stack}{$key}};
- delete $self->{stack}{$key} unless @{$self->{stack}{$key}};
- }
-
- return $val;
-}
-
-sub values_set {
- my $self = shift;
- return undef unless ref($self);
- return $self->{values};
-}
-
-sub all_config {
- my $self = shift;
- my $v = ref($self) ? $self->{values} : {};
- return {%Config, %$v};
-}
-
-1;
+++ /dev/null
-package Module::Build::ConfigData;
-use strict;
-my $arrayref = eval do {local $/; <DATA>}
- or die "Couldn't load ConfigData data: $@";
-close DATA;
-my ($config, $features, $auto_features) = @$arrayref;
-
-sub config { $config->{$_[1]} }
-
-sub set_config { $config->{$_[1]} = $_[2] }
-sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0
-
-sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features }
-
-sub feature_names {
- my @features = (keys %$features, auto_feature_names());
- @features;
-}
-
-sub config_names { keys %$config }
-
-sub write {
- my $me = __FILE__;
-
- # Can't use Module::Build::Dumper here because M::B is only a
- # build-time prereq of this module
- require Data::Dumper;
-
- my $mode_orig = (stat $me)[2] & 07777;
- chmod($mode_orig | 0222, $me); # Make it writeable
- open(my $fh, '+<', $me) or die "Can't rewrite $me: $!";
- seek($fh, 0, 0);
- while (<$fh>) {
- last if /^__DATA__$/;
- }
- die "Couldn't find __DATA__ token in $me" if eof($fh);
-
- seek($fh, tell($fh), 0);
- my $data = [$config, $features, $auto_features];
- print($fh 'do{ my '
- . Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
- . '$x; }' );
- truncate($fh, tell($fh));
- close $fh;
-
- chmod($mode_orig, $me)
- or warn "Couldn't restore permissions on $me: $!";
-}
-
-sub feature {
- my ($package, $key) = @_;
- return $features->{$key} if exists $features->{$key};
-
- my $info = $auto_features->{$key} or return 0;
-
- # Under perl 5.005, each(%$foo) isn't working correctly when $foo
- # was reanimated with Data::Dumper and eval(). Not sure why, but
- # copying to a new hash seems to solve it.
- my %info = %$info;
-
- require Module::Build; # XXX should get rid of this
- while (my ($type, $prereqs) = each %info) {
- next if $type eq 'description' || $type eq 'recommends';
-
- my %p = %$prereqs; # Ditto here.
- while (my ($modname, $spec) = each %p) {
- my $status = Module::Build->check_installed_status($modname, $spec);
- if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
- if ( ! eval "require $modname; 1" ) { return 0; }
- }
- }
- return 1;
-}
-
-
-=head1 NAME
-
-Module::Build::ConfigData - Configuration for Module::Build
-
-=head1 SYNOPSIS
-
- use Module::Build::ConfigData;
- $value = Module::Build::ConfigData->config('foo');
- $value = Module::Build::ConfigData->feature('bar');
-
- @names = Module::Build::ConfigData->config_names;
- @names = Module::Build::ConfigData->feature_names;
-
- Module::Build::ConfigData->set_config(foo => $new_value);
- Module::Build::ConfigData->set_feature(bar => $new_value);
- Module::Build::ConfigData->write; # Save changes
-
-
-=head1 DESCRIPTION
-
-This module holds the configuration data for the C<Module::Build>
-module. It also provides a programmatic interface for getting or
-setting that configuration data. Note that in order to actually make
-changes, you'll have to have write access to the C<Module::Build::ConfigData>
-module, and you should attempt to understand the repercussions of your
-actions.
-
-
-=head1 METHODS
-
-=over 4
-
-=item config($name)
-
-Given a string argument, returns the value of the configuration item
-by that name, or C<undef> if no such item exists.
-
-=item feature($name)
-
-Given a string argument, returns the value of the feature by that
-name, or C<undef> if no such feature exists.
-
-=item set_config($name, $value)
-
-Sets the configuration item with the given name to the given value.
-The value may be any Perl scalar that will serialize correctly using
-C<Data::Dumper>. This includes references, objects (usually), and
-complex data structures. It probably does not include transient
-things like filehandles or sockets.
-
-=item set_feature($name, $value)
-
-Sets the feature with the given name to the given boolean value. The
-value will be converted to 0 or 1 automatically.
-
-=item config_names()
-
-Returns a list of all the names of config items currently defined in
-C<Module::Build::ConfigData>, or in scalar context the number of items.
-
-=item feature_names()
-
-Returns a list of all the names of features currently defined in
-C<Module::Build::ConfigData>, or in scalar context the number of features.
-
-=item auto_feature_names()
-
-Returns a list of all the names of features whose availability is
-dynamically determined, or in scalar context the number of such
-features. Does not include such features that have later been set to
-a fixed value.
-
-=item write()
-
-Commits any changes from C<set_config()> and C<set_feature()> to disk.
-Requires write access to the C<Module::Build::ConfigData> module.
-
-=back
-
-
-=head1 AUTHOR
-
-C<Module::Build::ConfigData> was automatically created using C<Module::Build>.
-C<Module::Build> was written by Ken Williams, but he holds no
-authorship claim or copyright claim to the contents of C<Module::Build::ConfigData>.
-
-=cut
-
-
-__DATA__
-do{ my $x = [
- {},
- {},
- {
- 'dist_authoring' => {
- 'requires' => {
- 'Archive::Tar' => '1.09'
- },
- 'description' => 'Create new distributions',
- 'recommends' => {
- 'Pod::Readme' => '0.04',
- 'Module::Signature' => '0.21'
- }
- },
- 'HTML_support' => {
- 'requires' => {
- 'Pod::Html' => 0
- },
- 'description' => 'Create HTML documentation'
- },
- 'manpage_support' => {
- 'requires' => {
- 'Pod::Man' => 0
- },
- 'description' => 'Create Unix man pages'
- },
- 'license_creation' => {
- 'requires' => {
- 'Software::License' => '0.103009'
- },
- 'description' => 'Create licenses automatically in distributions'
- },
- 'PPM_support' => {
- 'description' => 'Generate PPM files for distributions'
- },
- 'inc_bundling_support' => {
- 'requires' => {
- 'ExtUtils::Installed' => '1.999',
- 'ExtUtils::Install' => '1.54'
- },
- 'description' => 'Bundle Module::Build in inc/'
- }
- }
- ];
-$x; }
\ No newline at end of file
+++ /dev/null
-package Module::Build::Cookbook;
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-
-
-=head1 NAME
-
-Module::Build::Cookbook - Examples of Module::Build Usage
-
-=head1 DESCRIPTION
-
-C<Module::Build> isn't conceptually very complicated, but examples are
-always helpful. The following recipes should help developers and/or
-installers put together the pieces from the other parts of the
-documentation.
-
-
-=head1 BASIC RECIPES
-
-
-=head2 Installing modules that use Module::Build
-
-In most cases, you can just issue the following commands:
-
- perl Build.PL
- ./Build
- ./Build test
- ./Build install
-
-There's nothing complicated here - first you're running a script
-called F<Build.PL>, then you're running a (newly-generated) script
-called F<Build> and passing it various arguments.
-
-The exact commands may vary a bit depending on how you invoke perl
-scripts on your system. For instance, if you have multiple versions
-of perl installed, you can install to one particular perl's library
-directories like so:
-
- /usr/bin/perl5.8.1 Build.PL
- ./Build
- ./Build test
- ./Build install
-
-If you're on Windows where the current directory is always searched
-first for scripts, you'll probably do something like this:
-
- perl Build.PL
- Build
- Build test
- Build install
-
-On the old Mac OS (version 9 or lower) using MacPerl, you can
-double-click on the F<Build.PL> script to create the F<Build> script,
-then double-click on the F<Build> script to run its C<build>, C<test>,
-and C<install> actions.
-
-The F<Build> script knows what perl was used to run F<Build.PL>, so
-you don't need to re-invoke the F<Build> script with the complete perl
-path each time. If you invoke it with the I<wrong> perl path, you'll
-get a warning or a fatal error.
-
-=head2 Modifying Config.pm values
-
-C<Module::Build> relies heavily on various values from perl's
-C<Config.pm> to do its work. For example, default installation paths
-are given by C<installsitelib> and C<installvendorman3dir> and
-friends, C linker & compiler settings are given by C<ld>,
-C<lddlflags>, C<cc>, C<ccflags>, and so on. I<If you're pretty sure
-you know what you're doing>, you can tell C<Module::Build> to pretend
-there are different values in F<Config.pm> than what's really there,
-by passing arguments for the C<--config> parameter on the command
-line:
-
- perl Build.PL --config cc=gcc --config ld=gcc
-
-Inside the C<Build.PL> script the same thing can be accomplished by
-passing values for the C<config> parameter to C<new()>:
-
- my $build = Module::Build->new
- (
- ...
- config => { cc => 'gcc', ld => 'gcc' },
- ...
- );
-
-In custom build code, the same thing can be accomplished by calling
-the L<Module::Build/config> method:
-
- $build->config( cc => 'gcc' ); # Set
- $build->config( ld => 'gcc' ); # Set
- ...
- my $linker = $build->config('ld'); # Get
-
-
-=head2 Installing modules using the programmatic interface
-
-If you need to build, test, and/or install modules from within some
-other perl code (as opposed to having the user type installation
-commands at the shell), you can use the programmatic interface.
-Create a Module::Build object (or an object of a custom Module::Build
-subclass) and then invoke its C<dispatch()> method to run various
-actions.
-
- my $build = Module::Build->new
- (
- module_name => 'Foo::Bar',
- license => 'perl',
- requires => { 'Some::Module' => '1.23' },
- );
- $build->dispatch('build');
- $build->dispatch('test', verbose => 1);
- $build->dispatch('install');
-
-The first argument to C<dispatch()> is the name of the action, and any
-following arguments are named parameters.
-
-This is the interface we use to test Module::Build itself in the
-regression tests.
-
-
-=head2 Installing to a temporary directory
-
-To create packages for package managers like RedHat's C<rpm> or
-Debian's C<deb>, you may need to install to a temporary directory
-first and then create the package from that temporary installation.
-To do this, specify the C<destdir> parameter to the C<install> action:
-
- ./Build install --destdir /tmp/my-package-1.003
-
-This essentially just prepends all the installation paths with the
-F</tmp/my-package-1.003> directory.
-
-
-=head2 Installing to a non-standard directory
-
-To install to a non-standard directory (for example, if you don't have
-permission to install in the system-wide directories), you can use the
-C<install_base> or C<prefix> parameters:
-
- ./Build install --install_base /foo/bar
-
-See L<Module::Build/"INSTALL PATHS"> for a much more complete
-discussion of how installation paths are determined.
-
-
-=head2 Installing in the same location as ExtUtils::MakeMaker
-
-With the introduction of C<--prefix> in Module::Build 0.28 and
-C<INSTALL_BASE> in C<ExtUtils::MakeMaker> 6.31 its easy to get them both
-to install to the same locations.
-
-First, ensure you have at least version 0.28 of Module::Build
-installed and 6.31 of C<ExtUtils::MakeMaker>. Prior versions have
-differing (and in some cases quite strange) installation behaviors.
-
-The following installation flags are equivalent between
-C<ExtUtils::MakeMaker> and C<Module::Build>.
-
- MakeMaker Module::Build
- PREFIX=... --prefix ...
- INSTALL_BASE=... --install_base ...
- DESTDIR=... --destdir ...
- LIB=... --install_path lib=...
- INSTALLDIRS=... --installdirs ...
- INSTALLDIRS=perl --installdirs core
- UNINST=... --uninst ...
- INC=... --extra_compiler_flags ...
- POLLUTE=1 --extra_compiler_flags -DPERL_POLLUTE
-
-For example, if you are currently installing C<MakeMaker> modules with
-this command:
-
- perl Makefile.PL PREFIX=~
- make test
- make install UNINST=1
-
-You can install into the same location with Module::Build using this:
-
- perl Build.PL --prefix ~
- ./Build test
- ./Build install --uninst 1
-
-=head3 C<prefix> vs C<install_base>
-
-The behavior of C<prefix> is complicated and depends 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, it's difficult to document
-where C<prefix> will place your modules.
-
-In contrast, C<install_base> has predictable, easy to explain
-installation locations. Now that C<Module::Build> and C<MakeMaker> both
-have C<install_base> there is little reason to use C<prefix> other
-than to preserve your existing installation locations. If you are
-starting a fresh Perl installation we encourage you to use
-C<install_base>. If you have an existing installation installed via
-C<prefix>, consider moving it to an installation structure matching
-C<install_base> and using that instead.
-
-
-=head2 Running a single test file
-
-C<Module::Build> supports running a single test, which enables you to
-track down errors more quickly. Use the following format:
-
- ./Build test --test_files t/mytest.t
-
-In addition, you may want to run the test in verbose mode to get more
-informative output:
-
- ./Build test --test_files t/mytest.t --verbose 1
-
-I run this so frequently that I define the following shell alias:
-
- alias t './Build test --verbose 1 --test_files'
-
-So then I can just execute C<t t/mytest.t> to run a single test.
-
-
-=head1 ADVANCED RECIPES
-
-
-=head2 Making a CPAN.pm-compatible distribution
-
-New versions of CPAN.pm understand how to use a F<Build.PL> script,
-but old versions don't. If authors want to help users who have old
-versions, some form of F<Makefile.PL> should be supplied. The easiest
-way to accomplish this is to use the C<create_makefile_pl> parameter to
-C<< Module::Build->new() >> in the C<Build.PL> script, which can
-create various flavors of F<Makefile.PL> during the C<dist> action.
-
-As a best practice, we recommend using the "traditional" style of
-F<Makefile.PL> unless your distribution has needs that can't be
-accomplished that way.
-
-The C<Module::Build::Compat> module, which is part of
-C<Module::Build>'s distribution, is responsible for creating these
-F<Makefile.PL>s. Please see L<Module::Build::Compat> for the details.
-
-
-=head2 Changing the order of the build process
-
-The C<build_elements> property specifies the steps C<Module::Build>
-will take when building a distribution. To change the build order,
-change the order of the entries in that property:
-
- # Process pod files first
- my @e = @{$build->build_elements};
- my ($i) = grep {$e[$_] eq 'pod'} 0..$#e;
- unshift @e, splice @e, $i, 1;
-
-Currently, C<build_elements> has the following default value:
-
- [qw( PL support pm xs pod script )]
-
-Do take care when altering this property, since there may be
-non-obvious (and non-documented!) ordering dependencies in the
-C<Module::Build> code.
-
-
-=head2 Adding new file types to the build process
-
-Sometimes you might have extra types of files that you want to install
-alongside the standard types like F<.pm> and F<.pod> files. For
-instance, you might have a F<Bar.dat> file containing some data
-related to the C<Foo::Bar> module and you'd like for it to end up as
-F<Foo/Bar.dat> somewhere in perl's C<@INC> path so C<Foo::Bar> can
-access it easily at runtime. The following code from a sample
-C<Build.PL> file demonstrates how to accomplish this:
-
- use Module::Build;
- my $build = Module::Build->new
- (
- module_name => 'Foo::Bar',
- ...other stuff here...
- );
- $build->add_build_element('dat');
- $build->create_build_script;
-
-This will find all F<.dat> files in the F<lib/> directory, copy them
-to the F<blib/lib/> directory during the C<build> action, and install
-them during the C<install> action.
-
-If your extra files aren't located in the C<lib/> directory in your
-distribution, you can explicitly say where they are, just as you'd do
-with F<.pm> or F<.pod> files:
-
- use Module::Build;
- my $build = new Module::Build
- (
- module_name => 'Foo::Bar',
- dat_files => {'some/dir/Bar.dat' => 'lib/Foo/Bar.dat'},
- ...other stuff here...
- );
- $build->add_build_element('dat');
- $build->create_build_script;
-
-If your extra files actually need to be created on the user's machine,
-or if they need some other kind of special processing, you'll probably
-want to subclass C<Module::Build> and create a special method to
-process them, named C<process_${kind}_files()>:
-
- use Module::Build;
- my $class = Module::Build->subclass(code => <<'EOF');
- sub process_dat_files {
- my $self = shift;
- ... locate and process *.dat files,
- ... and create something in blib/lib/
- }
- EOF
- my $build = $class->new
- (
- module_name => 'Foo::Bar',
- ...other stuff here...
- );
- $build->add_build_element('dat');
- $build->create_build_script;
-
-If your extra files don't go in F<lib/> but in some other place, see
-L<"Adding new elements to the install process"> for how to actually
-get them installed.
-
-Please note that these examples use some capabilities of Module::Build
-that first appeared in version 0.26. Before that it could
-still be done, but the simple cases took a bit more work.
-
-
-=head2 Adding new elements to the install process
-
-By default, Module::Build creates seven subdirectories of the F<blib>
-directory during the build process: F<lib>, F<arch>, F<bin>,
-F<script>, F<bindoc>, F<libdoc>, and F<html> (some of these may be
-missing or empty if there's nothing to go in them). Anything copied
-to these directories during the build will eventually be installed
-during the C<install> action (see L<Module::Build/"INSTALL PATHS">.
-
-If you need to create a new custom type of installable element, e.g. C<conf>,
-then you need to tell Module::Build where things in F<blib/conf/>
-should be installed. To do this, use the C<install_path> parameter to
-the C<new()> method:
-
- my $build = Module::Build->new
- (
- ...other stuff here...
- install_path => { conf => $installation_path }
- );
-
-Or you can call the C<install_path()> method later:
-
- $build->install_path(conf => $installation_path);
-
-The user may also specify the path on the command line:
-
- perl Build.PL --install_path conf=/foo/path/etc
-
-The important part, though, is that I<somehow> the install path needs
-to be set, or else nothing in the F<blib/conf/> directory will get
-installed, and a runtime error during the C<install> action will
-result.
-
-See also L<"Adding new file types to the build process"> for how to
-create the stuff in F<blib/conf/> in the first place.
-
-
-=head1 EXAMPLES ON CPAN
-
-Several distributions on CPAN are making good use of various features
-of Module::Build. They can serve as real-world examples for others.
-
-
-=head2 SVN-Notify-Mirror
-
-L<http://search.cpan.org/~jpeacock/SVN-Notify-Mirror/>
-
-John Peacock, author of the C<SVN-Notify-Mirror> distribution, says:
-
-=over 4
-
-=item 1. Using C<auto_features>, I check to see whether two optional
-modules are available - SVN::Notify::Config and Net::SSH;
-
-=item 2. If the S::N::Config module is loaded, I automatically
-generate test files for it during Build (using the C<PL_files>
-property).
-
-=item 3. If the C<ssh_feature> is available, I ask if the user wishes
-to perform the ssh tests (since it requires a little preliminary
-setup);
-
-=item 4. Only if the user has C<ssh_feature> and answers yes to the
-testing, do I generate a test file.
-
-I'm sure I could not have handled this complexity with EU::MM, but it
-was very easy to do with M::B.
-
-=back
-
-
-=head2 Modifying an action
-
-Sometimes you might need an to have an action, say C<./Build install>,
-do something unusual. For instance, you might need to change the
-ownership of a file or do something else peculiar to your application.
-
-You can subclass C<Module::Build> on the fly using the C<subclass()>
-method and override the methods that perform the actions. You may
-need to read through C<Module::Build::Authoring> and
-C<Module::Build::API> to find the methods you want to override. All
-"action" methods are implemented by a method called "ACTION_" followed
-by the action's name, so here's an example of how it would work for
-the C<install> action:
-
- # Build.PL
- use Module::Build;
- my $class = Module::Build->subclass(
- class => "Module::Build::Custom",
- code => <<'SUBCLASS' );
-
- sub ACTION_install {
- my $self = shift;
- # YOUR CODE HERE
- $self->SUPER::ACTION_install;
- }
- SUBCLASS
-
- $class->new(
- module_name => 'Your::Module',
- # rest of the usual Module::Build parameters
- )->create_build_script;
-
-
-=head2 Adding an action
-
-You can add a new C<./Build> action simply by writing the method for
-it in your subclass. Use C<depends_on> to declare that another action
-must have been run before your action.
-
-For example, let's say you wanted to be able to write C<./Build
-commit> to test your code and commit it to Subversion.
-
- # Build.PL
- use Module::Build;
- my $class = Module::Build->subclass(
- class => "Module::Build::Custom",
- code => <<'SUBCLASS' );
-
- sub ACTION_commit {
- my $self = shift;
-
- $self->depends_on("test");
- $self->do_system(qw(svn commit));
- }
- SUBCLASS
-
-
-=head2 Bundling Module::Build
-
-Note: This section probably needs an update as the technology improves
-(see contrib/bundle.pl in the distribution).
-
-Suppose you want to use some new-ish features of Module::Build,
-e.g. newer than the version of Module::Build your users are likely to
-already have installed on their systems. The first thing you should
-do is set C<configure_requires> to your minimum version of
-Module::Build. See L<Module::Build::Authoring>.
-
-But not every build system honors C<configure_requires> yet. Here's
-how you can ship a copy of Module::Build, but still use a newer
-installed version to take advantage of any bug fixes and upgrades.
-
-First, install Module::Build into F<Your-Project/inc/Module-Build>.
-CPAN will not index anything in the F<inc> directory so this copy will
-not show up in CPAN searches.
-
- cd Module-Build
- perl Build.PL --install_base /path/to/Your-Project/inc/Module-Build
- ./Build test
- ./Build install
-
-You should now have all the Module::Build .pm files in
-F<Your-Project/inc/Module-Build/lib/perl5>.
-
-Next, add this to the top of your F<Build.PL>.
-
- my $Bundled_MB = 0.30; # or whatever version it was.
-
- # Find out what version of Module::Build is installed or fail quietly.
- # This should be cross-platform.
- my $Installed_MB =
- `$^X -e "eval q{require Module::Build; print Module::Build->VERSION} or exit 1";
-
- # some operating systems put a newline at the end of every print.
- chomp $Installed_MB;
-
- $Installed_MB = 0 if $?;
-
- # Use our bundled copy of Module::Build if it's newer than the installed.
- unshift @INC, "inc/Module-Build/lib/perl5" if $Bundled_MB > $Installed_MB;
-
- require Module::Build;
-
-And write the rest of your F<Build.PL> normally. Module::Build will
-remember your change to C<@INC> and use it when you run F<./Build>.
-
-In the future, we hope to provide a more automated solution for this
-scenario; see C<inc/latest.pm> in the Module::Build distribution for
-one indication of the direction we're moving.
-
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-
-=head1 COPYRIGHT
-
-Copyright (c) 2001-2008 Ken Williams. All rights reserved.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-
-=head1 SEE ALSO
-
-perl(1), L<Module::Build>(3), L<Module::Build::Authoring>(3),
-L<Module::Build::API>(3)
-
-=cut
+++ /dev/null
-package Module::Build::Dumper;
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-
-# This is just a split-out of a wrapper function to do Data::Dumper
-# stuff "the right way". See:
-# http://groups.google.com/group/perl.module.build/browse_thread/thread/c8065052b2e0d741
-
-use Data::Dumper;
-
-sub _data_dump {
- my ($self, $data) = @_;
- return ("do{ my "
- . Data::Dumper->new([$data],['x'])->Purity(1)->Terse(0)->Dump()
- . '$x; }')
-}
-
-1;
+++ /dev/null
-# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
-# vim:ts=8:sw=2:et:sta:sts=2
-package Module::Build::ModuleInfo;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-
-require Module::Metadata;
-our @ISA = qw/Module::Metadata/;
-
-1;
-
-__END__
-
-=for :stopwords ModuleInfo
-
-=head1 NAME
-
-Module::Build::ModuleInfo - DEPRECATED
-
-=head1 DESCRIPTION
-
-This module has been extracted into a separate distribution and renamed
-L<Module::Metadata>. This module is kept as a subclass wrapper for
-compatibility.
-
-=head1 SEE ALSO
-
-perl(1), L<Module::Build>, L<Module::Metadata>
-
-=cut
-
+++ /dev/null
-package Module::Build::Notes;
-
-# A class for persistent hashes
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Data::Dumper;
-use Module::Build::Dumper;
-
-sub new {
- my ($class, %args) = @_;
- my $file = delete $args{file} or die "Missing required parameter 'file' to new()";
- my $self = bless {
- disk => {},
- new => {},
- file => $file,
- %args,
- }, $class;
-}
-
-sub restore {
- my $self = shift;
-
- open(my $fh, '<', $self->{file}) or die "Can't read $self->{file}: $!";
- $self->{disk} = eval do {local $/; <$fh>};
- die $@ if $@;
- close $fh;
- $self->{new} = {};
-}
-
-sub access {
- my $self = shift;
- return $self->read() unless @_;
-
- my $key = shift;
- return $self->read($key) unless @_;
-
- my $value = shift;
- $self->write({ $key => $value });
- return $self->read($key);
-}
-
-sub has_data {
- my $self = shift;
- return keys %{$self->read()} > 0;
-}
-
-sub exists {
- my ($self, $key) = @_;
- return exists($self->{new}{$key}) || exists($self->{disk}{$key});
-}
-
-sub read {
- my $self = shift;
-
- if (@_) {
- # Return 1 key as a scalar
- my $key = shift;
- return $self->{new}{$key} if exists $self->{new}{$key};
- return $self->{disk}{$key};
- }
-
- # Return all data
- my $out = (keys %{$self->{new}}
- ? {%{$self->{disk}}, %{$self->{new}}}
- : $self->{disk});
- return wantarray ? %$out : $out;
-}
-
-sub _same {
- my ($self, $x, $y) = @_;
- return 1 if !defined($x) and !defined($y);
- return 0 if !defined($x) or !defined($y);
- return $x eq $y;
-}
-
-sub write {
- my ($self, $href) = @_;
- $href ||= {};
-
- @{$self->{new}}{ keys %$href } = values %$href; # Merge
-
- # Do some optimization to avoid unnecessary writes
- foreach my $key (keys %{ $self->{new} }) {
- next if ref $self->{new}{$key};
- next if ref $self->{disk}{$key} or !exists $self->{disk}{$key};
- delete $self->{new}{$key} if $self->_same($self->{new}{$key}, $self->{disk}{$key});
- }
-
- if (my $file = $self->{file}) {
- my ($vol, $dir, $base) = File::Spec->splitpath($file);
- $dir = File::Spec->catpath($vol, $dir, '');
- return unless -e $dir && -d $dir; # The user needs to arrange for this
-
- return if -e $file and !keys %{ $self->{new} }; # Nothing to do
-
- @{$self->{disk}}{ keys %{$self->{new}} } = values %{$self->{new}}; # Merge
- $self->_dump($file, $self->{disk});
-
- $self->{new} = {};
- }
- return $self->read;
-}
-
-sub _dump {
- my ($self, $file, $data) = @_;
-
- open(my $fh, '>', $file) or die "Can't create '$file': $!";
- print {$fh} Module::Build::Dumper->_data_dump($data);
- close $fh;
-}
-
-my $orig_template = do { local $/; <DATA> };
-close DATA;
-
-sub write_config_data {
- my ($self, %args) = @_;
-
- my $template = $orig_template;
- $template =~ s/NOTES_NAME/$args{config_module}/g;
- $template =~ s/MODULE_NAME/$args{module}/g;
- $template =~ s/=begin private\n//;
- $template =~ s/=end private/=cut/;
-
- # strip out private POD markers we use to keep pod from being
- # recognized for *this* source file
- $template =~ s{$_\n}{} for '=begin private', '=end private';
-
- open(my $fh, '>', $args{file}) or die "Can't create '$args{file}': $!";
- print {$fh} $template;
- print {$fh} "\n__DATA__\n";
- print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
- close $fh;
-}
-
-1;
-
-
-=head1 NAME
-
-Module::Build::Notes - Create persistent distribution configuration modules
-
-=head1 DESCRIPTION
-
-This module is used internally by Module::Build to create persistent
-configuration files that can be installed with a distribution. See
-L<Module::Build::ConfigData> for an example.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2001-2006 Ken Williams. All rights reserved.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-perl(1), L<Module::Build>(3)
-
-=cut
-
-__DATA__
-package NOTES_NAME;
-use strict;
-my $arrayref = eval do {local $/; <DATA>}
- or die "Couldn't load ConfigData data: $@";
-close DATA;
-my ($config, $features, $auto_features) = @$arrayref;
-
-sub config { $config->{$_[1]} }
-
-sub set_config { $config->{$_[1]} = $_[2] }
-sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0
-
-sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features }
-
-sub feature_names {
- my @features = (keys %$features, auto_feature_names());
- @features;
-}
-
-sub config_names { keys %$config }
-
-sub write {
- my $me = __FILE__;
-
- # Can't use Module::Build::Dumper here because M::B is only a
- # build-time prereq of this module
- require Data::Dumper;
-
- my $mode_orig = (stat $me)[2] & 07777;
- chmod($mode_orig | 0222, $me); # Make it writeable
- open(my $fh, '+<', $me) or die "Can't rewrite $me: $!";
- seek($fh, 0, 0);
- while (<$fh>) {
- last if /^__DATA__$/;
- }
- die "Couldn't find __DATA__ token in $me" if eof($fh);
-
- seek($fh, tell($fh), 0);
- my $data = [$config, $features, $auto_features];
- print($fh 'do{ my '
- . Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
- . '$x; }' );
- truncate($fh, tell($fh));
- close $fh;
-
- chmod($mode_orig, $me)
- or warn "Couldn't restore permissions on $me: $!";
-}
-
-sub feature {
- my ($package, $key) = @_;
- return $features->{$key} if exists $features->{$key};
-
- my $info = $auto_features->{$key} or return 0;
-
- # Under perl 5.005, each(%$foo) isn't working correctly when $foo
- # was reanimated with Data::Dumper and eval(). Not sure why, but
- # copying to a new hash seems to solve it.
- my %info = %$info;
-
- require Module::Build; # XXX should get rid of this
- while (my ($type, $prereqs) = each %info) {
- next if $type eq 'description' || $type eq 'recommends';
-
- my %p = %$prereqs; # Ditto here.
- while (my ($modname, $spec) = each %p) {
- my $status = Module::Build->check_installed_status($modname, $spec);
- if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
- if ( ! eval "require $modname; 1" ) { return 0; }
- }
- }
- return 1;
-}
-
-=begin private
-
-=head1 NAME
-
-NOTES_NAME - Configuration for MODULE_NAME
-
-=head1 SYNOPSIS
-
- use NOTES_NAME;
- $value = NOTES_NAME->config('foo');
- $value = NOTES_NAME->feature('bar');
-
- @names = NOTES_NAME->config_names;
- @names = NOTES_NAME->feature_names;
-
- NOTES_NAME->set_config(foo => $new_value);
- NOTES_NAME->set_feature(bar => $new_value);
- NOTES_NAME->write; # Save changes
-
-
-=head1 DESCRIPTION
-
-This module holds the configuration data for the C<MODULE_NAME>
-module. It also provides a programmatic interface for getting or
-setting that configuration data. Note that in order to actually make
-changes, you'll have to have write access to the C<NOTES_NAME>
-module, and you should attempt to understand the repercussions of your
-actions.
-
-
-=head1 METHODS
-
-=over 4
-
-=item config($name)
-
-Given a string argument, returns the value of the configuration item
-by that name, or C<undef> if no such item exists.
-
-=item feature($name)
-
-Given a string argument, returns the value of the feature by that
-name, or C<undef> if no such feature exists.
-
-=item set_config($name, $value)
-
-Sets the configuration item with the given name to the given value.
-The value may be any Perl scalar that will serialize correctly using
-C<Data::Dumper>. This includes references, objects (usually), and
-complex data structures. It probably does not include transient
-things like filehandles or sockets.
-
-=item set_feature($name, $value)
-
-Sets the feature with the given name to the given boolean value. The
-value will be converted to 0 or 1 automatically.
-
-=item config_names()
-
-Returns a list of all the names of config items currently defined in
-C<NOTES_NAME>, or in scalar context the number of items.
-
-=item feature_names()
-
-Returns a list of all the names of features currently defined in
-C<NOTES_NAME>, or in scalar context the number of features.
-
-=item auto_feature_names()
-
-Returns a list of all the names of features whose availability is
-dynamically determined, or in scalar context the number of such
-features. Does not include such features that have later been set to
-a fixed value.
-
-=item write()
-
-Commits any changes from C<set_config()> and C<set_feature()> to disk.
-Requires write access to the C<NOTES_NAME> module.
-
-=back
-
-
-=head1 AUTHOR
-
-C<NOTES_NAME> was automatically created using C<Module::Build>.
-C<Module::Build> was written by Ken Williams, but he holds no
-authorship claim or copyright claim to the contents of C<NOTES_NAME>.
-
-=end private
-
+++ /dev/null
-package Module::Build::PPMMaker;
-
-use strict;
-use Config;
-use vars qw($VERSION);
-
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-
-# This code is mostly borrowed from ExtUtils::MM_Unix 6.10_03, with a
-# few tweaks based on the PPD spec at
-# http://www.xav.com/perl/site/lib/XML/PPD.html
-
-# The PPD spec is based on <http://www.w3.org/TR/NOTE-OSD>
-
-sub new {
- my $package = shift;
- return bless {@_}, $package;
-}
-
-sub make_ppd {
- my ($self, %args) = @_;
- my $build = delete $args{build};
-
- my @codebase;
- if (exists $args{codebase}) {
- @codebase = ref $args{codebase} ? @{$args{codebase}} : ($args{codebase});
- } else {
- my $distfile = $build->ppm_name . '.tar.gz';
- print "Using default codebase '$distfile'\n";
- @codebase = ($distfile);
- }
-
- my %dist;
- foreach my $info (qw(name author abstract version)) {
- my $method = "dist_$info";
- $dist{$info} = $build->$method() or die "Can't determine distribution's $info\n";
- }
-
- $self->_simple_xml_escape($_) foreach $dist{abstract}, @{$dist{author}};
-
- # TODO: could add <LICENSE HREF=...> tag if we knew what the URLs were for
- # various licenses
- my $ppd = <<"PPD";
-<SOFTPKG NAME=\"$dist{name}\" VERSION=\"$dist{version}\">
- <ABSTRACT>$dist{abstract}</ABSTRACT>
-@{[ join "\n", map " <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
- <IMPLEMENTATION>
-PPD
-
- # We don't include recommended dependencies because PPD has no way
- # to distinguish them from normal dependencies. We don't include
- # build_requires dependencies because the PPM installer doesn't
- # build or test before installing. And obviously we don't include
- # conflicts either.
-
- foreach my $type (qw(requires)) {
- my $prereq = $build->$type();
- while (my ($modname, $spec) = each %$prereq) {
- next if $modname eq 'perl';
-
- my $min_version = '0.0';
- foreach my $c ($build->_parse_conditions($spec)) {
- my ($op, $version) = $c =~ /^\s* (<=?|>=?|==|!=) \s* ([\w.]+) \s*$/x;
-
- # This is a nasty hack because it fails if there is no >= op
- if ($op eq '>=') {
- $min_version = $version;
- last;
- }
- }
-
- # PPM4 spec requires a '::' for top level modules
- $modname .= '::' unless $modname =~ /::/;
-
- $ppd .= qq! <REQUIRE NAME="$modname" VERSION="$min_version" />\n!;
- }
- }
-
- # We only include these tags if this module involves XS, on the
- # assumption that pure Perl modules will work on any OS.
- if (keys %{$build->find_xs_files}) {
- my $perl_version = $self->_ppd_version($build->perl_version);
- $ppd .= sprintf(<<'EOF', $self->_varchname($build->config) );
- <ARCHITECTURE NAME="%s" />
-EOF
- }
-
- foreach my $codebase (@codebase) {
- $self->_simple_xml_escape($codebase);
- $ppd .= sprintf(<<'EOF', $codebase);
- <CODEBASE HREF="%s" />
-EOF
- }
-
- $ppd .= <<'EOF';
- </IMPLEMENTATION>
-</SOFTPKG>
-EOF
-
- my $ppd_file = "$dist{name}.ppd";
- open(my $fh, '>', $ppd_file)
- or die "Cannot write to $ppd_file: $!";
-
- binmode($fh, ":utf8")
- if $] >= 5.008 && $Config{useperlio};
- print $fh $ppd;
- close $fh;
-
- return $ppd_file;
-}
-
-sub _ppd_version {
- my ($self, $version) = @_;
-
- # generates something like "0,18,0,0"
- return join ',', (split(/\./, $version), (0)x4)[0..3];
-}
-
-sub _varchname { # Copied from PPM.pm
- my ($self, $config) = @_;
- my $varchname = $config->{archname};
- # Append "-5.8" to architecture name for Perl 5.8 and later
- if ($] >= 5.008) {
- my $vstring = sprintf "%vd", $^V;
- $vstring =~ s/\.\d+$//;
- $varchname .= "-$vstring";
- }
- return $varchname;
-}
-
-{
- my %escapes = (
- "\n" => "\\n",
- '"' => '"',
- '&' => '&',
- '>' => '>',
- '<' => '<',
- );
- my $rx = join '|', keys %escapes;
-
- sub _simple_xml_escape {
- $_[1] =~ s/($rx)/$escapes{$1}/go;
- }
-}
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::PPMMaker - Perl Package Manager file creation
-
-=head1 SYNOPSIS
-
- On the command line, builds a .ppd file:
- ./Build ppd
-
-
-=head1 DESCRIPTION
-
-This package contains the code that builds F<.ppd> "Perl Package
-Description" files, in support of ActiveState's "Perl Package
-Manager". Details are here:
-L<http://aspn.activestate.com/ASPN/Downloads/ActivePerl/PPM/>
-
-
-=head1 AUTHOR
-
-Dave Rolsky <autarch@urth.org>, Ken Williams <kwilliams@cpan.org>
-
-
-=head1 COPYRIGHT
-
-Copyright (c) 2001-2006 Ken Williams. All rights reserved.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::Default;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Base;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Base);
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::Platform::Default - Stub class for unknown platforms
-
-=head1 DESCRIPTION
-
-The sole purpose of this module is to inherit from
-C<Module::Build::Base>. Please see the L<Module::Build> for the docs.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::MacOS;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Base;
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Base);
-
-use ExtUtils::Install;
-
-sub have_forkpipe { 0 }
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new(@_);
-
- # $Config{sitelib} and $Config{sitearch} are, unfortunately, missing.
- foreach ('sitelib', 'sitearch') {
- $self->config($_ => $self->config("install$_"))
- unless $self->config($_);
- }
-
- # For some reason $Config{startperl} is filled with a bunch of crap.
- (my $sp = $self->config('startperl')) =~ s/.*Exit \{Status\}\s//;
- $self->config(startperl => $sp);
-
- return $self;
-}
-
-sub make_executable {
- my $self = shift;
- require MacPerl;
- foreach (@_) {
- MacPerl::SetFileInfo('McPL', 'TEXT', $_);
- }
-}
-
-sub dispatch {
- my $self = shift;
-
- if( !@_ and !@ARGV ) {
- require MacPerl;
-
- # What comes first in the action list.
- my @action_list = qw(build test install);
- my %actions = map {+($_, 1)} $self->known_actions;
- delete @actions{@action_list};
- push @action_list, sort { $a cmp $b } keys %actions;
-
- my %toolserver = map {+$_ => 1} qw(test disttest diff testdb);
- foreach (@action_list) {
- $_ .= ' *' if $toolserver{$_};
- }
-
- my $cmd = MacPerl::Pick("What build command? ('*' requires ToolServer)", @action_list);
- return unless defined $cmd;
- $cmd =~ s/ \*$//;
- $ARGV[0] = ($cmd);
-
- my $args = MacPerl::Ask('Any extra arguments? (ie. verbose=1)', '');
- return unless defined $args;
- push @ARGV, $self->split_like_shell($args);
- }
-
- $self->SUPER::dispatch(@_);
-}
-
-sub ACTION_realclean {
- my $self = shift;
- chmod 0666, $self->{properties}{build_script};
- $self->SUPER::ACTION_realclean;
-}
-
-# ExtUtils::Install has a hard-coded '.' directory in versions less
-# than 1.30. We use a sneaky trick to turn that into ':'.
-#
-# Note that we do it here in a cross-platform way, so this code could
-# actually go in Module::Build::Base. But we put it here to be less
-# intrusive for other platforms.
-
-sub ACTION_install {
- my $self = shift;
-
- return $self->SUPER::ACTION_install(@_)
- if eval {ExtUtils::Install->VERSION('1.30'); 1};
-
- local $^W = 0; # Avoid a 'redefine' warning
- local *ExtUtils::Install::find = sub {
- my ($code, @dirs) = @_;
-
- @dirs = map { $_ eq '.' ? File::Spec->curdir : $_ } @dirs;
-
- return File::Find::find($code, @dirs);
- };
-
- return $self->SUPER::ACTION_install(@_);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Module::Build::Platform::MacOS - Builder class for MacOS platforms
-
-=head1 DESCRIPTION
-
-The sole purpose of this module is to inherit from
-C<Module::Build::Base> and override a few methods. Please see
-L<Module::Build> for the docs.
-
-=head2 Overridden Methods
-
-=over 4
-
-=item new()
-
-MacPerl doesn't define $Config{sitelib} or $Config{sitearch} for some
-reason, but $Config{installsitelib} and $Config{installsitearch} are
-there. So we copy the install variables to the other location
-
-=item make_executable()
-
-On MacOS we set the file type and creator to MacPerl so it will run
-with a double-click.
-
-=item dispatch()
-
-Because there's no easy way to say "./Build test" on MacOS, if
-dispatch is called with no arguments and no @ARGV a dialog box will
-pop up asking what action to take and any extra arguments.
-
-Default action is "test".
-
-=item ACTION_realclean()
-
-Need to unlock the Build program before deleting.
-
-=back
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern@pobox.com>
-
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::Unix;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Base;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Base);
-
-sub is_executable {
- # We consider the owner bit to be authoritative on a file, because
- # -x will always return true if the user is root and *any*
- # executable bit is set. The -x test seems to try to answer the
- # question "can I execute this file", but I think we want "is this
- # file executable".
-
- my ($self, $file) = @_;
- return +(stat $file)[2] & 0100;
-}
-
-sub _startperl { "#! " . shift()->perl }
-
-sub _construct {
- my $self = shift()->SUPER::_construct(@_);
-
- # perl 5.8.1-RC[1-3] had some broken %Config entries, and
- # unfortunately Red Hat 9 shipped it like that. Fix 'em up here.
- my $c = $self->{config};
- for (qw(siteman1 siteman3 vendorman1 vendorman3)) {
- $c->{"install${_}dir"} ||= $c->{"install${_}"};
- }
-
- return $self;
-}
-
-# Open group says username should be portable filename characters,
-# but some Unix OS working with ActiveDirectory wind up with user-names
-# with back-slashes in the name. The new code below is very liberal
-# in what it accepts.
-sub _detildefy {
- my ($self, $value) = @_;
- $value =~ s[^~([^/]+)?(?=/|$)] # tilde with optional username
- [$1 ?
- (eval{(getpwnam $1)[7]} || "~$1") :
- ($ENV{HOME} || eval{(getpwuid $>)[7]} || glob("~"))
- ]ex;
- return $value;
-}
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::Platform::Unix - Builder class for Unix platforms
-
-=head1 DESCRIPTION
-
-The sole purpose of this module is to inherit from
-C<Module::Build::Base>. Please see the L<Module::Build> for the docs.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::VMS;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Base;
-use Config;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Base);
-
-
-
-=head1 NAME
-
-Module::Build::Platform::VMS - Builder class for VMS platforms
-
-=head1 DESCRIPTION
-
-This module inherits from C<Module::Build::Base> and alters a few
-minor details of its functionality. Please see L<Module::Build> for
-the general docs.
-
-=head2 Overridden Methods
-
-=over 4
-
-=item _set_defaults
-
-Change $self->{build_script} to 'Build.com' so @Build works.
-
-=cut
-
-sub _set_defaults {
- my $self = shift;
- $self->SUPER::_set_defaults(@_);
-
- $self->{properties}{build_script} = 'Build.com';
-}
-
-
-=item cull_args
-
-'@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing
-people to write '@Build "foo"' we'll dispatch case-insensitively.
-
-=cut
-
-sub cull_args {
- my $self = shift;
- my($action, $args) = $self->SUPER::cull_args(@_);
- my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
-
- die "Ambiguous action '$action'. Could be one of @possible_actions"
- if @possible_actions > 1;
-
- return ($possible_actions[0], $args);
-}
-
-
-=item manpage_separator
-
-Use '__' instead of '::'.
-
-=cut
-
-sub manpage_separator {
- return '__';
-}
-
-
-=item prefixify
-
-Prefixify taking into account VMS' filepath syntax.
-
-=cut
-
-# Translated from ExtUtils::MM_VMS::prefixify()
-
-sub _catprefix {
- my($self, $rprefix, $default) = @_;
-
- my($rvol, $rdirs) = File::Spec->splitpath($rprefix);
- if( $rvol ) {
- return File::Spec->catpath($rvol,
- File::Spec->catdir($rdirs, $default),
- ''
- )
- }
- else {
- return File::Spec->catdir($rdirs, $default);
- }
-}
-
-
-sub _prefixify {
- my($self, $path, $sprefix, $type) = @_;
- my $rprefix = $self->prefix;
-
- return '' unless defined $path;
-
- $self->log_verbose(" prefixify $path from $sprefix to $rprefix\n");
-
- # Translate $(PERLPREFIX) to a real path.
- $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
- $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
-
- $self->log_verbose(" rprefix translated to $rprefix\n".
- " sprefix translated to $sprefix\n");
-
- if( length($path) == 0 ) {
- $self->log_verbose(" no path to prefixify.\n")
- }
- elsif( !File::Spec->file_name_is_absolute($path) ) {
- $self->log_verbose(" path is relative, not prefixifying.\n");
- }
- elsif( $sprefix eq $rprefix ) {
- $self->log_verbose(" no new prefix.\n");
- }
- else {
- my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
- my $vms_prefix = $self->config('vms_prefix');
- if( $path_vol eq $vms_prefix.':' ) {
- $self->log_verbose(" $vms_prefix: seen\n");
-
- $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
- $path = $self->_catprefix($rprefix, $path_dirs);
- }
- else {
- $self->log_verbose(" cannot prefixify.\n");
- return $self->prefix_relpaths($self->installdirs, $type);
- }
- }
-
- $self->log_verbose(" now $path\n");
-
- return $path;
-}
-
-=item _quote_args
-
-Command-line arguments (but not the command itself) must be quoted
-to ensure case preservation.
-
-=cut
-
-sub _quote_args {
- # Returns a string that can become [part of] a command line with
- # proper quoting so that the subprocess sees this same list of args,
- # or if we get a single arg that is an array reference, quote the
- # elements of it and return the reference.
- my ($self, @args) = @_;
- my $got_arrayref = (scalar(@args) == 1
- && UNIVERSAL::isa($args[0], 'ARRAY'))
- ? 1
- : 0;
-
- # Do not quote qualifiers that begin with '/'.
- map { if (!/^\//) {
- $_ =~ s/\"/""/g; # escape C<"> by doubling
- $_ = q(").$_.q(");
- }
- }
- ($got_arrayref ? @{$args[0]}
- : @args
- );
-
- return $got_arrayref ? $args[0]
- : join(' ', @args);
-}
-
-=item have_forkpipe
-
-There is no native fork(), so some constructs depending on it are not
-available.
-
-=cut
-
-sub have_forkpipe { 0 }
-
-=item _backticks
-
-Override to ensure that we quote the arguments but not the command.
-
-=cut
-
-sub _backticks {
- # The command must not be quoted but the arguments to it must be.
- my ($self, @cmd) = @_;
- my $cmd = shift @cmd;
- my $args = $self->_quote_args(@cmd);
- return `$cmd $args`;
-}
-
-=item find_command
-
-Local an executable program
-
-=cut
-
-sub find_command {
- my ($self, $command) = @_;
-
- # a lot of VMS executables have a symbol defined
- # check those first
- if ( $^O eq 'VMS' ) {
- require VMS::DCLsym;
- my $syms = VMS::DCLsym->new;
- return $command if scalar $syms->getsym( uc $command );
- }
-
- $self->SUPER::find_command($command);
-}
-
-# _maybe_command copied from ExtUtils::MM_VMS::maybe_command
-
-=item _maybe_command (override)
-
-Follows VMS naming conventions for executable files.
-If the name passed in doesn't exactly match an executable file,
-appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
-to check for DCL procedure. If this fails, checks directories in DCL$PATH
-and finally F<Sys$System:> for an executable file having the name specified,
-with or without the F<.Exe>-equivalent suffix.
-
-=cut
-
-sub _maybe_command {
- my($self,$file) = @_;
- return $file if -x $file && ! -d _;
- my(@dirs) = ('');
- my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
-
- if ($file !~ m![/:>\]]!) {
- for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
- my $dir = $ENV{"DCL\$PATH;$i"};
- $dir .= ':' unless $dir =~ m%[\]:]$%;
- push(@dirs,$dir);
- }
- push(@dirs,'Sys$System:');
- foreach my $dir (@dirs) {
- my $sysfile = "$dir$file";
- foreach my $ext (@exts) {
- return $file if -x "$sysfile$ext" && ! -d _;
- }
- }
- }
- return;
-}
-
-=item do_system
-
-Override to ensure that we quote the arguments but not the command.
-
-=cut
-
-sub do_system {
- # The command must not be quoted but the arguments to it must be.
- my ($self, @cmd) = @_;
- $self->log_verbose("@cmd\n");
- my $cmd = shift @cmd;
- my $args = $self->_quote_args(@cmd);
- return !system("$cmd $args");
-}
-
-=item oneliner
-
-Override to ensure that we do not quote the command.
-
-=cut
-
-sub oneliner {
- my $self = shift;
- my $oneliner = $self->SUPER::oneliner(@_);
-
- $oneliner =~ s/^\"\S+\"//;
-
- return "MCR $^X $oneliner";
-}
-
-=item rscan_dir
-
-Inherit the standard version but remove dots at end of name.
-If the extended character set is in effect, do not remove dots from filenames
-with Unix path delimiters.
-
-=cut
-
-sub rscan_dir {
- my ($self, $dir, $pattern) = @_;
-
- my $result = $self->SUPER::rscan_dir( $dir, $pattern );
-
- for my $file (@$result) {
- if (!_efs() && ($file =~ m#/#)) {
- $file =~ s/\.$//;
- }
- }
- return $result;
-}
-
-=item dist_dir
-
-Inherit the standard version but replace embedded dots with underscores because
-a dot is the directory delimiter on VMS.
-
-=cut
-
-sub dist_dir {
- my $self = shift;
-
- my $dist_dir = $self->SUPER::dist_dir;
- $dist_dir =~ s/\./_/g unless _efs();
- return $dist_dir;
-}
-
-=item man3page_name
-
-Inherit the standard version but chop the extra manpage delimiter off the front if
-there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
-
-=cut
-
-sub man3page_name {
- my $self = shift;
-
- my $mpname = $self->SUPER::man3page_name( shift );
- my $sep = $self->manpage_separator;
- $mpname =~ s/^$sep//;
- return $mpname;
-}
-
-=item expand_test_dir
-
-Inherit the standard version but relativize the paths as the native glob() doesn't
-do that for us.
-
-=cut
-
-sub expand_test_dir {
- my ($self, $dir) = @_;
-
- my @reldirs = $self->SUPER::expand_test_dir( $dir );
-
- for my $eachdir (@reldirs) {
- my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
- my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
- $eachdir = File::Spec->catfile( $reldir, $f );
- }
- return @reldirs;
-}
-
-=item _detildefy
-
-The home-grown glob() does not currently handle tildes, so provide limited support
-here. Expect only UNIX format file specifications for now.
-
-=cut
-
-sub _detildefy {
- my ($self, $arg) = @_;
-
- # Apparently double ~ are not translated.
- return $arg if ($arg =~ /^~~/);
-
- # Apparently ~ followed by whitespace are not translated.
- return $arg if ($arg =~ /^~ /);
-
- if ($arg =~ /^~/) {
- my $spec = $arg;
-
- # Remove the tilde
- $spec =~ s/^~//;
-
- # Remove any slash following the tilde if present.
- $spec =~ s#^/##;
-
- # break up the paths for the merge
- my $home = VMS::Filespec::unixify($ENV{HOME});
-
- # In the default VMS mode, the trailing slash is present.
- # In Unix report mode it is not. The parsing logic assumes that
- # it is present.
- $home .= '/' unless $home =~ m#/$#;
-
- # Trivial case of just ~ by it self
- if ($spec eq '') {
- $home =~ s#/$##;
- return $home;
- }
-
- my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
- if ($hdir eq '') {
- # Someone has tampered with $ENV{HOME}
- # So hfile is probably the directory since this should be
- # a path.
- $hdir = $hfile;
- }
-
- my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
-
- my @hdirs = File::Spec::Unix->splitdir($hdir);
- my @dirs = File::Spec::Unix->splitdir($dir);
-
- unless ($arg =~ m#^~/#) {
- # There is a home directory after the tilde, but it will already
- # be present in in @hdirs so we need to remove it by from @dirs.
-
- shift @dirs;
- }
- my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
-
- $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
- }
- return $arg;
-
-}
-
-=item find_perl_interpreter
-
-On VMS, $^X returns the fully qualified absolute path including version
-number. It's logically impossible to improve on it for getting the perl
-we're currently running, and attempting to manipulate it is usually
-lossy.
-
-=cut
-
-sub find_perl_interpreter {
- return VMS::Filespec::vmsify($^X);
-}
-
-=item localize_file_path
-
-Convert the file path to the local syntax
-
-=cut
-
-sub localize_file_path {
- my ($self, $path) = @_;
- $path = VMS::Filespec::vmsify($path);
- $path =~ s/\.\z//;
- return $path;
-}
-
-=item localize_dir_path
-
-Convert the directory path to the local syntax
-
-=cut
-
-sub localize_dir_path {
- my ($self, $path) = @_;
- return VMS::Filespec::vmspath($path);
-}
-
-=item ACTION_clean
-
-The home-grown glob() expands a bit too aggressively when given a bare name,
-so default in a zero-length extension.
-
-=cut
-
-sub ACTION_clean {
- my ($self) = @_;
- foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
- $self->delete_filetree($item);
- }
-}
-
-
-# Need to look up the feature settings. The preferred way is to use the
-# VMS::Feature module, but that may not be available to dual life modules.
-
-my $use_feature;
-BEGIN {
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
- $use_feature = 1;
- }
-}
-
-# Need to look up the UNIX report mode. This may become a dynamic mode
-# in the future.
-sub _unix_rpt {
- my $unix_rpt;
- if ($use_feature) {
- $unix_rpt = VMS::Feature::current("filename_unix_report");
- } else {
- my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
- }
- return $unix_rpt;
-}
-
-# Need to look up the EFS character set mode. This may become a dynamic
-# mode in the future.
-sub _efs {
- my $efs;
- if ($use_feature) {
- $efs = VMS::Feature::current("efs_charset");
- } else {
- my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
- $efs = $env_efs =~ /^[ET1]/i;
- }
- return $efs;
-}
-
-=back
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern@pobox.com>
-Ken Williams <kwilliams@cpan.org>
-Craig A. Berry <craigberry@mac.com>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
-
-1;
-__END__
+++ /dev/null
-package Module::Build::Platform::VOS;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Base;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Base);
-
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::Platform::VOS - Builder class for VOS platforms
-
-=head1 DESCRIPTION
-
-The sole purpose of this module is to inherit from
-C<Module::Build::Base>. Please see the L<Module::Build> for the docs.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::Windows;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-
-use Config;
-use File::Basename;
-use File::Spec;
-
-use Module::Build::Base;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Base);
-
-
-sub manpage_separator {
- return '.';
-}
-
-sub have_forkpipe { 0 }
-
-sub _detildefy {
- my ($self, $value) = @_;
- $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
- if $ENV{HOME};
- return $value;
-}
-
-sub ACTION_realclean {
- my ($self) = @_;
-
- $self->SUPER::ACTION_realclean();
-
- my $basename = basename($0);
- $basename =~ s/(?:\.bat)?$//i;
-
- if ( lc $basename eq lc $self->build_script ) {
- if ( $self->build_bat ) {
- $self->log_verbose("Deleting $basename.bat\n");
- my $full_progname = $0;
- $full_progname =~ s/(?:\.bat)?$/.bat/i;
-
- # Voodoo required to have a batch file delete itself without error;
- # Syntax differs between 9x & NT: the later requires a null arg (???)
- require Win32;
- my $null_arg = (Win32::IsWinNT()) ? '""' : '';
- my $cmd = qq(start $null_arg /min "\%comspec\%" /c del "$full_progname");
-
- open(my $fh, '>>', "$basename.bat")
- or die "Can't create $basename.bat: $!";
- print $fh $cmd;
- close $fh ;
- } else {
- $self->delete_filetree($self->build_script . '.bat');
- }
- }
-}
-
-sub make_executable {
- my $self = shift;
-
- $self->SUPER::make_executable(@_);
-
- foreach my $script (@_) {
-
- # Native batch script
- if ( $script =~ /\.(bat|cmd)$/ ) {
- $self->SUPER::make_executable($script);
- next;
-
- # Perl script that needs to be wrapped in a batch script
- } else {
- my %opts = ();
- if ( $script eq $self->build_script ) {
- $opts{ntargs} = q(-x -S %0 --build_bat %*);
- $opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
- }
-
- my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
- if ( $@ ) {
- $self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
- } else {
- $self->SUPER::make_executable($out);
- }
- }
- }
-}
-
-# This routine was copied almost verbatim from the 'pl2bat' utility
-# distributed with perl. It requires too much voodoo with shell quoting
-# differences and shortcomings between the various flavors of Windows
-# to reliably shell out
-sub pl2bat {
- my $self = shift;
- my %opts = @_;
-
- # NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate
- $opts{ntargs} = '-x -S %0 %*' unless exists $opts{ntargs};
- $opts{otherargs} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9' unless exists $opts{otherargs};
-
- $opts{stripsuffix} = '/\\.plx?/' unless exists $opts{stripsuffix};
- $opts{stripsuffix} = ($opts{stripsuffix} =~ m{^/([^/]*[^/\$]|)\$?/?$} ? $1 : "\Q$opts{stripsuffix}\E");
-
- unless (exists $opts{out}) {
- $opts{out} = $opts{in};
- $opts{out} =~ s/$opts{stripsuffix}$//oi;
- $opts{out} .= '.bat' unless $opts{in} =~ /\.bat$/i or $opts{in} =~ /^-$/;
- }
-
- my $head = <<EOT;
- \@rem = '--*-Perl-*--
- \@echo off
- if "%OS%" == "Windows_NT" goto WinNT
- perl $opts{otherargs}
- goto endofperl
- :WinNT
- perl $opts{ntargs}
- if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl
- if %errorlevel% == 9009 echo You do not have Perl in your PATH.
- if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
- goto endofperl
- \@rem ';
-EOT
-
- $head =~ s/^\s+//gm;
- my $headlines = 2 + ($head =~ tr/\n/\n/);
- my $tail = "\n__END__\n:endofperl\n";
-
- my $linedone = 0;
- my $taildone = 0;
- my $linenum = 0;
- my $skiplines = 0;
-
- my $start = $Config{startperl};
- $start = "#!perl" unless $start =~ /^#!.*perl/;
-
- open(my $in, '<', "$opts{in}") or die "Can't open $opts{in}: $!";
- my @file = <$in>;
- close($in);
-
- foreach my $line ( @file ) {
- $linenum++;
- if ( $line =~ /^:endofperl\b/ ) {
- if (!exists $opts{update}) {
- warn "$opts{in} has already been converted to a batch file!\n";
- return;
- }
- $taildone++;
- }
- if ( not $linedone and $line =~ /^#!.*perl/ ) {
- if (exists $opts{update}) {
- $skiplines = $linenum - 1;
- $line .= "#line ".(1+$headlines)."\n";
- } else {
- $line .= "#line ".($linenum+$headlines)."\n";
- }
- $linedone++;
- }
- if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) {
- $line = "";
- }
- }
-
- open(my $out, '>', "$opts{out}") or die "Can't open $opts{out}: $!";
- print $out $head;
- print $out $start, ( $opts{usewarnings} ? " -w" : "" ),
- "\n#line ", ($headlines+1), "\n" unless $linedone;
- print $out @file[$skiplines..$#file];
- print $out $tail unless $taildone;
- close($out);
-
- return $opts{out};
-}
-
-
-sub _quote_args {
- # Returns a string that can become [part of] a command line with
- # proper quoting so that the subprocess sees this same list of args.
- my ($self, @args) = @_;
-
- my @quoted;
-
- for (@args) {
- if ( /^[^\s*?!\$<>;|'"\[\]\{\}]+$/ ) {
- # Looks pretty safe
- push @quoted, $_;
- } else {
- # XXX this will obviously have to improve - is there already a
- # core module lying around that does proper quoting?
- s/"/\\"/g;
- push @quoted, qq("$_");
- }
- }
-
- return join " ", @quoted;
-}
-
-
-sub split_like_shell {
- # As it turns out, Windows command-parsing is very different from
- # Unix command-parsing. Double-quotes mean different things,
- # backslashes don't necessarily mean escapes, and so on. So we
- # can't use Text::ParseWords::shellwords() to break a command string
- # into words. The algorithm below was bashed out by Randy and Ken
- # (mostly Randy), and there are a lot of regression tests, so we
- # should feel free to adjust if desired.
-
- (my $self, local $_) = @_;
-
- return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
-
- my @argv;
- return @argv unless defined() && length();
-
- my $arg = '';
- my( $i, $quote_mode ) = ( 0, 0 );
-
- while ( $i < length() ) {
-
- my $ch = substr( $_, $i , 1 );
- my $next_ch = substr( $_, $i+1, 1 );
-
- if ( $ch eq '\\' && $next_ch eq '"' ) {
- $arg .= '"';
- $i++;
- } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
- $arg .= '\\';
- $i++;
- } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
- $quote_mode = !$quote_mode;
- $arg .= '"';
- $i++;
- } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
- ( $i + 2 == length() ||
- substr( $_, $i + 2, 1 ) eq ' ' )
- ) { # for cases like: a"" => [ 'a' ]
- push( @argv, $arg );
- $arg = '';
- $i += 2;
- } elsif ( $ch eq '"' ) {
- $quote_mode = !$quote_mode;
- } elsif ( $ch eq ' ' && !$quote_mode ) {
- push( @argv, $arg ) if $arg;
- $arg = '';
- ++$i while substr( $_, $i + 1, 1 ) eq ' ';
- } else {
- $arg .= $ch;
- }
-
- $i++;
- }
-
- push( @argv, $arg ) if defined( $arg ) && length( $arg );
- return @argv;
-}
-
-
-# system(@cmd) does not like having double-quotes in it on Windows.
-# So we quote them and run it as a single command.
-sub do_system {
- my ($self, @cmd) = @_;
-
- my $cmd = $self->_quote_args(@cmd);
- my $status = system($cmd);
- if ($status and $! =~ /Argument list too long/i) {
- my $env_entries = '';
- foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
- warn "'Argument list' was 'too long', env lengths are $env_entries";
- }
- return !$status;
-}
-
-# Copied from ExtUtils::MM_Win32
-sub _maybe_command {
- my($self,$file) = @_;
- my @e = exists($ENV{'PATHEXT'})
- ? split(/;/, $ENV{PATHEXT})
- : qw(.com .exe .bat .cmd);
- my $e = '';
- for (@e) { $e .= "\Q$_\E|" }
- chop $e;
- # see if file ends in one of the known extensions
- if ($file =~ /($e)$/i) {
- return $file if -e $file;
- }
- else {
- for (@e) {
- return "$file$_" if -e "$file$_";
- }
- }
- return;
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-Module::Build::Platform::Windows - Builder class for Windows platforms
-
-=head1 DESCRIPTION
-
-The sole purpose of this module is to inherit from
-C<Module::Build::Base> and override a few methods. Please see
-L<Module::Build> for the docs.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::aix;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Platform::Unix;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Platform::Unix);
-
-# This class isn't necessary anymore, but we can't delete it, because
-# some people might still have the old copy in their @INC, containing
-# code we don't want to execute, so we have to make sure an upgrade
-# will replace it with this empty subclass.
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::Platform::aix - Builder class for AIX platform
-
-=head1 DESCRIPTION
-
-This module provides some routines very specific to the AIX
-platform.
-
-Please see the L<Module::Build> for the general docs.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::cygwin;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Platform::Unix;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Platform::Unix);
-
-sub manpage_separator {
- '.'
-}
-
-# Copied from ExtUtils::MM_Cygwin::maybe_command()
-# If our path begins with F</cygdrive/> then we use the Windows version
-# to determine if it may be a command. Otherwise we use the tests
-# from C<ExtUtils::MM_Unix>.
-
-sub _maybe_command {
- my ($self, $file) = @_;
-
- if ($file =~ m{^/cygdrive/}i) {
- require Module::Build::Platform::Windows;
- return Module::Build::Platform::Windows->_maybe_command($file);
- }
-
- return $self->SUPER::_maybe_command($file);
-}
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::Platform::cygwin - Builder class for Cygwin platform
-
-=head1 DESCRIPTION
-
-This module provides some routines very specific to the cygwin
-platform.
-
-Please see the L<Module::Build> for the general docs.
-
-=head1 AUTHOR
-
-Initial stub by Yitzchak Scott-Thoennes <sthoenna@efn.org>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::darwin;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Platform::Unix;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Platform::Unix);
-
-# This class isn't necessary anymore, but we can't delete it, because
-# some people might still have the old copy in their @INC, containing
-# code we don't want to execute, so we have to make sure an upgrade
-# will replace it with this empty subclass.
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::Platform::darwin - Builder class for Mac OS X platform
-
-=head1 DESCRIPTION
-
-This module provides some routines very specific to the Mac OS X
-platform.
-
-Please see the L<Module::Build> for the general docs.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
+++ /dev/null
-package Module::Build::Platform::os2;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use Module::Build::Platform::Unix;
-
-use vars qw(@ISA);
-@ISA = qw(Module::Build::Platform::Unix);
-
-sub manpage_separator { '.' }
-
-sub have_forkpipe { 0 }
-
-# Copied from ExtUtils::MM_OS2::maybe_command
-sub _maybe_command {
- my($self,$file) = @_;
- $file =~ s,[/\\]+,/,g;
- return $file if -x $file && ! -d _;
- return "$file.exe" if -x "$file.exe" && ! -d _;
- return "$file.cmd" if -x "$file.cmd" && ! -d _;
- return;
-}
-
-1;
-__END__
-
-
-=head1 NAME
-
-Module::Build::Platform::os2 - Builder class for OS/2 platform
-
-=head1 DESCRIPTION
-
-This module provides some routines very specific to the OS/2
-platform.
-
-Please see the L<Module::Build> for the general docs.
-
-=head1 AUTHOR
-
-Ken Williams <kwilliams@cpan.org>
-
-=head1 SEE ALSO
-
-perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
-
-=cut
+++ /dev/null
-package Module::Build::PodParser;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-use vars qw(@ISA);
-
-sub new {
- # Perl is so fun.
- my $package = shift;
-
- my $self;
- @ISA = ();
- $self = bless {have_pod_parser => 0, @_}, $package;
-
- unless ($self->{fh}) {
- die "No 'file' or 'fh' parameter given" unless $self->{file};
- open($self->{fh}, '<', $self->{file}) or die "Couldn't open $self->{file}: $!";
- }
-
- return $self;
-}
-
-sub parse_from_filehandle {
- my ($self, $fh) = @_;
-
- local $_;
- while (<$fh>) {
- next unless /^=(?!cut)/ .. /^=cut/; # in POD
- # Accept Name - abstract or C<Name> - abstract
- last if ($self->{abstract}) = /^ (?: [a-z_0-9:]+ | [BCIF] < [a-z_0-9:]+ > ) \s+ - \s+ (.*\S) /ix;
- }
-
- my @author;
- while (<$fh>) {
- next unless /^=head1\s+AUTHORS?/i ... /^=/;
- next if /^=/;
- push @author, $_ if /\@/;
- }
- return unless @author;
- s/^\s+|\s+$//g foreach @author;
-
- $self->{author} = \@author;
-
- return;
-}
-
-sub get_abstract {
- my $self = shift;
- return $self->{abstract} if defined $self->{abstract};
-
- $self->parse_from_filehandle($self->{fh});
-
- return $self->{abstract};
-}
-
-sub get_author {
- my $self = shift;
- return $self->{author} if defined $self->{author};
-
- $self->parse_from_filehandle($self->{fh});
-
- return $self->{author} || [];
-}
+++ /dev/null
-package Module::Build::Version;
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.87'; ### XXX sync with version of version.pm below
-
-use version 0.87;
-our @ISA = qw(version);
-
-1;
-
-=head1 NAME
-
-Module::Build::Version - DEPRECATED
-
-=head1 DESCRIPTION
-
-Module::Build now lists L<version> as a C<configure_requires> dependency
-and no longer installs a copy.
-
-=cut
-
+++ /dev/null
-package Module::Build::YAML;
-use strict;
-use CPAN::Meta::YAML 0.002 ();
-our @ISA = qw(CPAN::Meta::YAML);
-our $VERSION = '1.41';
-1;
-
-=head1 NAME
-
-Module::Build::YAML - DEPRECATED
-
-=head1 DESCRIPTION
-
-This module was originally an inline copy of L<YAML::Tiny>. It has been
-deprecated in favor of using L<CPAN::Meta::YAML> directly. This module is kept
-as a subclass wrapper for compatibility.
-
-=cut
-
+++ /dev/null
-package inc::latest;
-
-use if $] >= 5.019, 'deprecate';
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-
-use Carp;
-use File::Basename ();
-use File::Spec ();
-use File::Path ();
-use File::Copy ();
-
-# track and return modules loaded by inc::latest
-my @loaded_modules;
-sub loaded_modules {@loaded_modules}
-
-# must ultimately "goto" the import routine of the module to be loaded
-# so that the calling package is correct when $mod->import() runs.
-sub import {
- my ($package, $mod, @args) = @_;
- return unless(defined $mod);
-
- my $private_path = 'inc/latest/private.pm';
- if(-e $private_path) {
- # user mode - delegate work to bundled private module
- require $private_path;
- splice( @_, 0, 1, 'inc::latest::private');
- goto \&inc::latest::private::import;
- }
-
- # author mode - just record and load the modules
- push(@loaded_modules, $mod);
- require inc::latest::private;
- goto \&inc::latest::private::_load_module;
-}
-
-sub write {
- my $package = shift;
- my ($where, @preload) = @_;
-
- warn "should really be writing in inc/" unless $where =~ /inc$/;
-
- # write inc/latest.pm
- File::Path::mkpath( $where );
- open my $fh, '>', File::Spec->catfile($where,'latest.pm');
- print {$fh} "# This stub created by inc::latest $VERSION\n";
- print {$fh} <<'HERE';
-package inc::latest;
-use strict;
-use vars '@ISA';
-require inc::latest::private;
-@ISA = qw/inc::latest::private/;
-HERE
- if (@preload) {
- print {$fh} "\npackage inc::latest::preload;\n";
- for my $mod (@preload) {
- print {$fh} "inc::latest->import('$mod');\n";
- }
- }
- print {$fh} "\n1;\n";
- close $fh;
-
- # write inc/latest/private;
- require inc::latest::private;
- File::Path::mkpath( File::Spec->catdir( $where, 'latest' ) );
- my $from = $INC{'inc/latest/private.pm'};
- my $to = File::Spec->catfile($where,'latest','private.pm');
- File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!";
-
- return 1;
-}
-
-sub bundle_module {
- my ($package, $module, $where) = @_;
-
- # create inc/inc_$foo
- (my $dist = $module) =~ s{::}{-}g;
- my $inc_lib = File::Spec->catdir($where,"inc_$dist");
- File::Path::mkpath $inc_lib;
-
- # get list of files to copy
- require ExtUtils::Installed;
- # workaround buggy EU::Installed check of @INC
- my $inst = ExtUtils::Installed->new(extra_libs => [@INC]);
- my $packlist = $inst->packlist( $module ) or die "Couldn't find packlist";
- my @files = grep { /\.pm$/ } keys %$packlist;
-
-
- # figure out prefix
- my $mod_path = quotemeta $package->_mod2path( $module );
- my ($prefix) = grep { /$mod_path$/ } @files;
- $prefix =~ s{$mod_path$}{};
-
- # copy files
- for my $from ( @files ) {
- next unless $from =~ /\.pm$/;
- (my $mod_path = $from) =~ s{^\Q$prefix\E}{};
- my $to = File::Spec->catfile( $inc_lib, $mod_path );
- File::Path::mkpath(File::Basename::dirname($to));
- File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!";
- }
- return 1;
-}
-
-# Translate a module name into a directory/file.pm to search for in @INC
-sub _mod2path {
- my ($self, $mod) = @_;
- my @parts = split /::/, $mod;
- $parts[-1] .= '.pm';
- return $parts[0] if @parts == 1;
- return File::Spec->catfile(@parts);
-}
-
-1;
-
-
-=head1 NAME
-
-inc::latest - use modules bundled in inc/ if they are newer than installed ones
-
-=head1 SYNOPSIS
-
- # in Build.PL
- use inc::latest 'Module::Build';
-
-=head1 DESCRIPTION
-
-The C<inc::latest> module helps bootstrap configure-time dependencies for CPAN
-distributions. These dependencies get bundled into the C<inc> directory within
-a distribution and are used by Build.PL (or Makefile.PL).
-
-Arguments to C<inc::latest> are module names that are checked against both the
-current C<@INC> array and against specially-named directories in C<inc>. If
-the bundled version is newer than the installed one (or the module isn't
-installed, then, the bundled directory is added to the start of <@INC> and the
-module is loaded from there.
-
-There are actually two variations of C<inc::latest> -- one for authors and one
-for the C<inc> directory. For distribution authors, the C<inc::latest>
-installed in the system will record modules loaded via C<inc::latest> and can
-be used to create the bundled files in C<inc>, including writing the second
-variation as C<inc/latest.pm>.
-
-This second C<inc::latest> is the one that is loaded in a distribution being
-installed (e.g. from Build.PL). This bundled C<inc::latest> is the one
-that determines which module to load.
-
-=head2 Special notes on bundling
-
-The C<inc::latest> module creates bundled directories based on the packlist
-file of an installed distribution. Even though C<inc::latest> takes module
-name arguments, it is better to think of it as bundling and making available
-entire I<distributions>. When a module is loaded through C<inc::latest>,
-it looks in all bundled distributions in C<inc/> for a newer module than
-can be found in the existing C<@INC> array.
-
-Thus, the module-name provided should usually be the "top-level" module name of
-a distribution, though this is not strictly required. For example,
-L<Module::Build> has a number of heuristics to map module names to packlists,
-allowing users to do things like this:
-
- use inc::latest 'Devel::AssertOS::Unix';
-
-even though Devel::AssertOS::Unix is contained within the Devel-CheckOS
-distribution.
-
-At the current time, packlists are required. Thus, bundling dual-core modules
-may require a 'forced install' over versions in the latest version of perl
-in order to create the necessary packlist for bundling.
-
-=head1 USAGE
-
-When calling C<use>, the bundled C<inc::latest> takes a single module name and
-optional arguments to pass to that module's own import method.
-
- use 'inc::latest' 'Foo::Bar' qw/foo bar baz/;
-
-=head2 Author-mode
-
-You are in author-mode inc::latest if any of the Author-mode methods are
-available. For example:
-
- if ( inc::latest->can('write') ) {
- inc::latest->write('inc');
- }
-
-=over 4
-
-=item loaded_modules()
-
- my @list = inc::latest->loaded_modules;
-
-This takes no arguments and always returns a list of module names requested for
-loading via "use inc::latest 'MODULE'", regardless of whether the load was
-successful or not.
-
-=item write()
-
- inc::latest->write( 'inc' );
-
-This writes the bundled version of inc::latest to the directory name given as an
-argument. It almost all cases, it should be 'C<inc>'.
-
-=item bundle_module()
-
- for my $mod ( inc::latest->loaded_modules ) {
- inc::latest->bundle_module($mod, $dir);
- }
-
-If $mod corresponds to a packlist, then this function creates a specially-named
-directory in $dir and copies all .pm files from the modlist to the new
-directory (which almost always should just be 'inc'). For example, if Foo::Bar
-is the name of the module, and $dir is 'inc', then the directory would be
-'inc/inc_Foo-Bar' and contain files like this:
-
- inc/inc_Foo-Bar/Foo/Bar.pm
-
-Currently, $mod B<must> have a packlist. If this is not the case (e.g. for a
-dual-core module), then the bundling will fail. You may be able to create a
-packlist by forced installing the module on top of the version that came with
-core Perl.
-
-=back
-
-=head2 As bundled in inc/
-
-All methods are private. Only the C<import> method is public.
-
-=head1 AUTHOR
-
-Eric Wilhelm <ewilhelm@cpan.org>, David Golden <dagolden@cpan.org>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2009 by Eric Wilhelm and David Golden
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<Module::Build>
-
-=cut
-
+++ /dev/null
-package inc::latest::private;
-
-use if $] >= 5.019, 'deprecate';
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.4205';
-$VERSION = eval $VERSION;
-
-use File::Spec;
-
-# must ultimately "goto" the import routine of the module to be loaded
-# so that the calling package is correct when $mod->import() runs.
-sub import {
- my ($package, $mod, @args) = @_;
- my $file = $package->_mod2path($mod);
-
- if ($INC{$file}) {
- # Already loaded, but let _load_module handle import args
- goto \&_load_module;
- }
-
- # A bundled copy must be present
- my ($bundled, $bundled_dir) = $package->_search_bundled($file)
- or die "No bundled copy of $mod found";
-
- my $from_inc = $package->_search_INC($file);
- unless ($from_inc) {
- # Only bundled is available
- unshift(@INC, $bundled_dir);
- goto \&_load_module;
- }
-
- if (_version($from_inc) >= _version($bundled)) {
- # Ignore the bundled copy
- goto \&_load_module;
- }
-
- # Load the bundled copy
- unshift(@INC, $bundled_dir);
- goto \&_load_module;
-}
-
-sub _version {
- require ExtUtils::MakeMaker;
- return ExtUtils::MM->parse_version(shift);
-}
-
-# use "goto" for import to preserve caller
-sub _load_module {
- my $package = shift; # remaining @_ is ready for goto
- my ($mod, @args) = @_;
- eval "require $mod; 1" or die $@;
- if ( my $import = $mod->can('import') ) {
- goto $import;
- }
- return 1;
-}
-
-sub _search_bundled {
- my ($self, $file) = @_;
-
- my $mypath = 'inc';
-
- opendir my $DH, $mypath or die "Can't open directory $mypath: $!";
-
- while (defined(my $e = readdir $DH)) {
- next unless $e =~ /^inc_/;
- my $try = File::Spec->catfile($mypath, $e, $file);
-
- return($try, File::Spec->catdir($mypath, $e)) if -e $try;
- }
- return;
-}
-
-# Look for the given path in @INC.
-sub _search_INC {
- # TODO: doesn't handle coderefs or arrayrefs or objects in @INC, but
- # it probably should
- my ($self, $file) = @_;
-
- foreach my $dir (@INC) {
- next if ref $dir;
- my $try = File::Spec->catfile($dir, $file);
- return $try if -e $try;
- }
-
- return;
-}
-
-# Translate a module name into a directory/file.pm to search for in @INC
-sub _mod2path {
- my ($self, $mod) = @_;
- my @parts = split /::/, $mod;
- $parts[-1] .= '.pm';
- return $parts[0] if @parts == 1;
- return File::Spec->catfile(@parts);
-}
-
-1;
-
-
+++ /dev/null
-use strict;
-use warnings;
-use lib 't/lib';
-use MBTest;
-use File::Find qw/find/;
-
-my @files;
-find( sub { -f && /\.pm$/ && push @files, $File::Find::name }, 'lib' );
-
-plan tests => scalar @files;
-
-for my $f ( sort @files ) {
- my $ec;
- my $output = stdout_stderr_of( sub { $ec = system( $^X, '-c', $f ) } );
- ok( ! $ec, "compiling $f" ) or diag $output;
-}
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 8;
-use DistGen;
-blib_load('Module::Build');
-
-my $dist;
-
-# Test that PL files don't get installed even in bin or lib
-{
- $dist = DistGen->new( dir => MBTest->tmpdir );
- $dist->regen;
- $dist->chdir_in;
-
- my $distname = $dist->name;
- $dist->change_build_pl({
- module_name => $distname,
- PL_files => {
- 'bin/foo.PL' => 'bin/foo',
- 'lib/Bar.pm.PL' => 'lib/Bar.pm',
- },
- });
-
- $dist->add_file("bin/foo.PL", <<'END');
-open my $fh, ">", $ARGV[0] or die $!;
-print $fh "foo\n";
-END
-
- $dist->add_file("lib/Bar.pm.PL", <<'END');
-open my $fh, ">", $ARGV[0] or die $!;
-print $fh "bar\n";
-END
-
- $dist->regen;
-
- my $mb = Module::Build->new_from_context( install_base => "test_install" );
- $mb->dispatch("install");
-
- ok -e "test_install/bin/foo", "Generated PL_files installed from bin";
- ok -e "test_install/lib/perl5/Bar.pm", " and from lib";
-
- ok !-e "test_install/bin/foo.PL", "PL_files not installed from bin";
- ok !-e "test_install/lib/perl5/Bar.pm.PL", " nor from lib";
-
- is slurp("test_install/bin/foo"), "foo\n", "Generated bin contains correct content";
- is slurp("test_install/lib/perl5/Bar.pm"), "bar\n", " so does the lib";
-
- $dist->chdir_original if $dist->did_chdir;
-}
-
-# Test an empty PL target list runs the PL but doesn't
-# add it to MANIFEST or cleanup
-{
- $dist = DistGen->new( dir => MBTest->tmpdir );
- $dist->regen;
- $dist->chdir_in;
-
- my $distname = $dist->name;
- $dist->change_build_pl({
- module_name => $distname,
- PL_files => {
- 'Special.PL' => [],
- },
- });
-
- $dist->add_file("Special.PL", <<'END');
-open my $fh, ">", "foo" or die $!;
-print $fh "foo\n";
-END
-
- $dist->regen;
-
- my $mb = Module::Build->new_from_context();
- $mb->dispatch("code");
-
- ok( -f "foo", "special PL file ran" );
-
- my $cleanup = $mb->cleanup;
-
- my %cleanup = map { $_ => 1 } $mb->cleanup;
- is($cleanup{foo}, undef, "generated special file not added to cleanup");
-
- $dist->chdir_original if $dist->did_chdir;
-}
+++ /dev/null
-=head1 A GUIDE TO WRITING TESTS FOR MODULE::BUILD
-
-This document provides tips on writing new tests for Module::Build. Please
-note that many existing tests were written prior to these guidelines and
-have many different styles. Please don't copy/paste old tests by rote without
-considering better ways to test. See C<sample.t> for a starter test file.
-
-=head1 TEST FILE PREAMBLE
-
-Every Module::Build test should begin with the same preamble to ensure that the
-test library is set properly and that the correct version of Module::Build is
-being tested.
-
- use strict;
- use lib 't/lib';
- use MBTest tests => 2; # or 'no_plan'
-
- blib_load('Module::Build');
-
-The C<MBTest> module is in C<t/lib/> and subclasses Test::More. When loaded
-it cleans up several environment variables that could cause problems,
-tweaks C<@INC> and exports several helper functions. See that module for
-details.
-
-=head1 CREATING A TEST DISTRIBUTION
-
-The C<DistGen> module in C<t/lib/> should be used to create sample
-distributions for testing. It provides numerous helpful methods to
-create a skeleton distribution, add files, change files, and so on.
-Run C<perldoc> on C<t/lib/DistGen.pm> to see the documentation.
-
- # CREATE A TEST DISTRIBUTION
-
- use DistGen;
-
- # create dist object in a temp directory
- my $dist = DistGen->new;
-
- # enter the test distribution directory before further testing
- $dist->chdir_in;
-
- # generate the skeleton files
- $dist->regen;
-
-
-=head1 GETTING A MODULE::BUILD OBJECT
-
-From inside the test distribution, you can get the Module::Build object
-configured in Build.PL using the C<new_from_context> method on the
-dist object. This is just like Module::Build's C<new_from_context> except
-it passes C<< quiet => 1 >> to avoid sending output to the terminal.
-Use the Module::Build object to test the programmatic API.
-
- my $mb = $dist->new_from_context( quiet => 1 );
- isa_ok( $mb, "Module::Build" );
- is( $mb->dist_name, "Simple", "dist_name is 'Simple'" );
-
-=head1 TESTING THE COMMAND LINE API
-
-The command line API is tested by running subprocesses, not via a Module::Build
-object. The C<DistGen> object has helper methods for running C<Build.PL> and
-C<Build> and passing arguments on the command line.
-
- $dist->run_build_pl( '--quiet' );
- $dist->run_build( 'test' );
-
-=head1 TYPICAL TESTING CYCLE
-
-The typical testing cycle is to generate or modify a test distribution, either
-through the C<DistGen> object or directly in the filesystem, then regenerate
-the distribution and test it (or run command line tests and observe the
-result.)
-
- # Modify the distribution
-
- $dist->change_build_pl(
- {
- module_name => $dist->name,
- license => 'artistic',
- }
- );
- $dist->regen;
-
- # Get a new build object and test it
-
- $mb = $dist->new_from_context;
- is( $mb->license, "artistic", "saw 'artistic' license" );
-
-
-=head1 COPYRIGHT
-
-This documentation is Copyright (C) 2009 by David Golden. You can redistribute
-it and/or modify it under the same terms as Perl 5.10.0.
-
+++ /dev/null
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-plan tests => 6;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-# create dist object in a temp directory
-# enter the directory and generate the skeleton files
-my $dist = DistGen->new->chdir_in;
-
-$dist->change_build_pl(
- module_name => $dist->name,
- requires => {
- 'File::Spec' => 9999,
- },
- build_requires => {
- 'Getopt::Long' => 9998,
- },
- cpan_client => $^X . ' -le print($_)for($^X,@ARGV)',
-)->regen;
-
-# get a Module::Build object and test with it
-my $mb;
-stdout_stderr_of( sub { $mb = $dist->new_from_context('verbose' => 1) } );
-isa_ok( $mb, "Module::Build" );
-like( $mb->cpan_client, qr/^\Q$^X\E/, "cpan_client is mocked with perl" );
-
-my $retval;
-my $out = stdout_of( sub {
- $retval = $mb->dispatch('installdeps')
-});
-ok( $retval, "ran mocked Build installdeps");
-like( $out, qr/File::Spec/, "saw File::Spec prereq" );
-like( $out, qr/Getopt::Long/, "saw Getopt::Long prereq" );
-
-$out = stdout_stderr_of( sub {
- $retval = $mb->dispatch('installdeps', cpan_client => 'ADLKASJDFLASDJ');
-});
-ok( !$retval, "Build installdeps with bad cpan_client fails" );
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-plan tests => 7;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-# create dist object in a temp directory
-# enter the directory and generate the skeleton files
-my $dist = DistGen->new->chdir_in;
-$dist->change_build_pl(
- module_name => $dist->name,
- requires => {
- 'File::Spec' => 9999,
- },
- build_requires => {
- 'Getopt::Long' => 9998,
- },
- cpan_client => $^X . ' -le print($_)for($^X,@ARGV)',
-)->regen;
-
-ok( ! -e 'MANIFEST.SKIP', "MANIFEST.SKIP doesn't exist at start" );
-
-# get a Module::Build object and test with it
-my $mb;
-stdout_stderr_of( sub { $mb = $dist->new_from_context('verbose' => 1) } );
-isa_ok( $mb, "Module::Build" );
-
-my ($out, $err) = stdout_stderr_of( sub {
- $dist->run_build('manifest_skip')
-});
-ok( -e 'MANIFEST.SKIP', "'Build manifest_skip' creates MANIFEST.SKIP" );
-like( $out, qr/Creating a new MANIFEST.SKIP file/, "Saw creation message");
-
-# shouldn't overwrite
-my $old_mtime = -M 'MANIFEST.SKIP';
-($out, $err) = stdout_stderr_of( sub {
- $dist->run_build('manifest_skip')
-});
-like( $err, qr/MANIFEST.SKIP already exists/,
- "Running it again warns about pre-existing MANIFEST.SKIP"
-);
-is( -M 'MANIFEST.SKIP', $old_mtime, "File does not appear modified" );
-
-# cleanup
-($out, $err) = stdout_stderr_of( sub {
- $dist->run_build('distclean')
-});
-ok( -e 'MANIFEST.SKIP', "MANIFEST.SKIP still exists after distclean" );
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 27;
-#use MBTest 'no_plan';
-use DistGen;
-
-blib_load 'Module::Build';
-
-my $tmp = MBTest->tmpdir;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-$dist->chdir_in;
-
-ADDPROP: {
- package My::Build::Prop;
- use base 'Module::Build';
- __PACKAGE__->add_property( 'foo' );
- __PACKAGE__->add_property( 'bar', 'howdy' );
- __PACKAGE__->add_property( 'baz', default => 'howdy' );
- __PACKAGE__->add_property( 'code', default => sub { 'yay' } );
- __PACKAGE__->add_property(
- 'check',
- default => sub { 'howdy' },
- check => sub {
- return 1 if $_ eq 'howdy';
- shift->property_error(qq{"$_" is invalid});
- return 0;
- },
- );
- __PACKAGE__->add_property(
- 'hash',
- default => { foo => 1 },
- check => sub {
- return 1 if !defined $_ or exists $_->{foo};
- shift->property_error(qq{hash is invalid});
- return 0;
- },
- );
-}
-
-ok my $build = My::Build::Prop->new(
- 'module_name' => 'Simple',
- quiet => 1,
-), 'Create new build object';
-
-is $build->foo, undef, 'Property "foo" should be undef';
-ok $build->foo(42), 'Set "foo"';
-is $build->foo, 42, 'Now "foo" should have new value';
-
-is $build->bar, 'howdy', 'Property "bar" should be its default';
-ok $build->bar('yo'), 'Set "bar"';
-is $build->bar, 'yo', 'Now "bar" should have new value';
-
-is $build->check, 'howdy', 'Property "check" should be its default';
-
-eval { $build->check('yo') };
-ok my $err = $@, 'Should get an error for an invalid value';
-like $err, qr/^ERROR: "yo" is invalid/, 'It should be the correct error';
-
-is $build->code, 'yay', 'Property "code" should have its code value';
-
-is_deeply $build->hash, { foo => 1 }, 'Property "hash" should be default';
-is $build->hash('foo'), 1, 'Should be able to get key in hash';
-ok $build->hash( bar => 3 ), 'Add a key to the hash prop';
-is_deeply $build->hash, { foo => 1, bar => 3 }, 'New key should be in hash';
-
-eval { $build->hash({ bar => 3 }) };
-ok $err = $@, 'Should get exception for assigning invalid hash';
-like $err, qr/^ERROR: hash is invalid/, 'It should be the correct error';
-
-eval { $build->hash( []) };
-ok $err = $@, 'Should get exception for assigning an array for a hash';
-like $err, qr/^Unexpected arguments for property 'hash'/,
- 'It should be the proper error';
-is $build->hash(undef), undef, 'Should be able to set hash to undef';
-
-# Check core properties.
-is $build->installdirs, 'site', 'Property "installdirs" should be default';
-ok $build->installdirs('core'), 'Set "installdirst" to "core"';
-is $build->installdirs, 'core', 'Now "installdirs" should be "core"';
-
-eval { $build->installdirs('perl') };
-ok $err = $@, 'Should have caught exception setting "installdirs" to "perl"';
-like $err, qr/^ERROR: Perhaps you meant installdirs to be "core" rather than "perl"\?/,
- 'And it should suggest "core" in the error message';
-
-eval { $build->installdirs('foo') };
-ok $err = $@, 'Should catch exception for invalid "installdirs" value';
-like $err, qr/ERROR: installdirs must be one of "core", "site", or "vendor"/,
- 'And it should suggest the proper values in the error message';
-
-$dist->chdir_original if $dist->did_chdir;
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 1;
-
-blib_load 'Module::Build';
-
-ADDPROP: {
- package My::Build::Prop;
- use base 'Module::Build';
- __PACKAGE__->add_property( 'list_property' => []);
-}
-
-ok grep { $_ eq 'bundle_inc' } My::Build::Prop->array_properties, "has bundle_inc even after adding another array property";
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 1;
-
-blib_load 'Module::Build';
-
-ADDPROP: {
- package My::Build::Prop;
- use base 'Module::Build';
- __PACKAGE__->add_property( 'hash_property' => {});
-}
-
-ok grep { $_ eq 'install_path' } My::Build::Prop->hash_properties, "has install_path even after adding another hash property";
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 58;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-$dist->chdir_in;
-
-#########################
-
-
-# Test object creation
-{
- my $mb = Module::Build->new( module_name => $dist->name );
- ok $mb;
- is $mb->module_name, $dist->name;
- is $mb->build_class, 'Module::Build';
- is $mb->dist_name, $dist->name;
-
- $mb = Module::Build->new( dist_name => $dist->name, dist_version => 7 );
- ok $mb;
- ok $mb->module_name; # Set via heuristics
- is $mb->dist_name, $dist->name;
-}
-
-# Make sure actions are defined, and known_actions works as class method
-{
- my %actions = map {$_, 1} Module::Build->known_actions;
- ok $actions{clean};
- ok $actions{distdir};
-}
-
-# Test prerequisite checking
-{
- local @INC = (File::Spec->catdir( $dist->dirname, 'lib' ), @INC);
- my $flagged = 0;
- local $SIG{__WARN__} = sub { $flagged = 1 if $_[0] =~ /@{[$dist->name]}/};
- my $mb = Module::Build->new(
- module_name => $dist->name,
- requires => {$dist->name => 0},
- );
- ok ! $flagged;
- ok ! $mb->prereq_failures;
- $mb->dispatch('realclean');
- $dist->clean;
-
- $flagged = 0;
- $mb = Module::Build->new(
- module_name => $dist->name,
- requires => {$dist->name => 3.14159265},
- );
- ok $flagged;
- ok $mb->prereq_failures;
- ok $mb->prereq_failures->{requires}{$dist->name};
- is $mb->prereq_failures->{requires}{$dist->name}{have}, "0.01";
- is $mb->prereq_failures->{requires}{$dist->name}{need}, "3.14159265";
-
- $mb->dispatch('realclean');
- $dist->clean;
-
- # Make sure check_installed_status() works as a class method
- my $info = Module::Build->check_installed_status('File::Spec', 0);
- ok $info->{ok};
- is $info->{have}, $File::Spec::VERSION;
-
- # Make sure check_installed_status() works with an advanced spec
- $info = Module::Build->check_installed_status('File::Spec', '> 0');
- ok $info->{ok};
-
- # Use 2 lines for this, to avoid a "used only once" warning
- local $Foo::Module::VERSION;
- $Foo::Module::VERSION = '1.01_02';
-
- $info = Module::Build->check_installed_status('Foo::Module', '1.01_02');
- ok $info->{ok} or diag($info->{message});
-}
-
-{
- # Make sure the correct warning message is generated when an
- # optional prereq isn't installed
- my $flagged = 0;
- local $SIG{__WARN__} = sub { $flagged = 1 if $_[0] =~ /ModuleBuildNonExistent is not installed/};
-
- my $mb = Module::Build->new(
- module_name => $dist->name,
- recommends => {ModuleBuildNonExistent => 3},
- );
- ok $flagged;
- $dist->clean;
-}
-
-# Test verbosity
-{
- my $mb = Module::Build->new(module_name => $dist->name);
-
- $mb->add_to_cleanup('save_out');
- # Use uc() so we don't confuse the current test output
- like uc(stdout_of( sub {$mb->dispatch('test', verbose => 1)} )), qr/^OK \d/m;
- like uc(stdout_of( sub {$mb->dispatch('test', verbose => 0)} )), qr/\.\. ?OK/;
-
- $mb->dispatch('realclean');
- $dist->clean;
-}
-
-# Make sure 'config' entries are respected on the command line, and that
-# Getopt::Long specs work as expected.
-{
- use Config;
- $dist->change_build_pl
- ({
- module_name => @{[$dist->name]},
- license => 'perl',
- get_options => { foo => {},
- bar => { type => '+' },
- bat => { type => '=s' },
- dee => { type => '=s',
- default => 'goo'
- },
- }
- });
-
- $dist->regen;
- eval {Module::Build->run_perl_script('Build.PL', [], ['--nouse-rcfile', '--config', "foocakes=barcakes", '--foo', '--bar', '--bar', '-bat=hello', 'gee=whiz', '--any', 'hey', '--destdir', 'yo', '--verbose', '1'])};
- is $@, '';
-
- my $mb = Module::Build->resume;
- ok $mb->valid_property('config');
-
- is $mb->config('cc'), $Config{cc};
- is $mb->config('foocakes'), 'barcakes';
-
- # Test args().
- is $mb->args('foo'), 1;
- is $mb->args('bar'), 2, 'bar';
- is $mb->args('bat'), 'hello', 'bat';
- is $mb->args('gee'), 'whiz';
- is $mb->args('any'), 'hey';
- is $mb->args('dee'), 'goo';
- is $mb->destdir, 'yo';
- my %runtime = $mb->runtime_params;
- is_deeply \%runtime,
- {
- verbose => 1,
- destdir => 'yo',
- use_rcfile => 0,
- config => { foocakes => 'barcakes' },
- };
-
- ok my $argsref = $mb->args;
- is $argsref->{foo}, 1;
- $argsref->{doo} = 'hee';
- is $mb->args('doo'), 'hee';
- ok my %args = $mb->args;
- is $args{foo}, 1;
-
- # revert test distribution to pristine state because we modified a file
- $dist->regen( clean => 1 );
-}
-
-# Test author stuff
-{
- my $mb = Module::Build->new(
- module_name => $dist->name,
- dist_author => 'Foo Meister <foo@example.com>',
- build_class => 'My::Big::Fat::Builder',
- );
- ok $mb;
- ok ref($mb->dist_author), 'dist_author converted to array if simple string';
- is $mb->dist_author->[0], 'Foo Meister <foo@example.com>';
- is $mb->build_class, 'My::Big::Fat::Builder';
-}
-
-# Test conversion of shell strings
-{
- my $mb = Module::Build->new(
- module_name => $dist->name,
- dist_author => 'Foo Meister <foo@example.com>',
- extra_compiler_flags => '-I/foo -I/bar',
- extra_linker_flags => '-L/foo -L/bar',
- );
- ok $mb;
- is_deeply $mb->extra_compiler_flags, ['-I/foo', '-I/bar'], "Should split shell string into list";
- is_deeply $mb->extra_linker_flags, ['-L/foo', '-L/bar'], "Should split shell string into list";
-
- # Try again with command-line args
- eval {Module::Build->run_perl_script('Build.PL', [], ['--extra_compiler_flags', '-I/foo -I/bar',
- '--extra_linker_flags', '-L/foo -L/bar'])};
- $mb = Module::Build->resume;
- ok $mb;
- is_deeply $mb->extra_compiler_flags, ['-I/foo', '-I/bar'], "Should split shell string into list";
- is_deeply $mb->extra_linker_flags, ['-L/foo', '-L/bar'], "Should split shell string into list";
-}
-
-# Test include_dirs.
-{
- ok my $mb = Module::Build->new(
- module_name => $dist->name,
- include_dirs => [qw(/foo /bar)],
- );
- is_deeply $mb->include_dirs, ['/foo', '/bar'], 'Should have include dirs';
-
- # Try a string.
- ok $mb = Module::Build->new(
- module_name => $dist->name,
- include_dirs => '/foo',
- );
- is_deeply $mb->include_dirs, ['/foo'], 'Should have string include dir';
-
- # Try again with command-line args
- eval { Module::Build->run_perl_script(
- 'Build.PL', [],
- ['--include_dirs', '/foo', '--include_dirs', '/bar' ],
- ) };
-
- ok $mb = Module::Build->resume;
- is_deeply $mb->include_dirs, ['/foo', '/bar'], 'Should have include dirs';
-
- eval { Module::Build->run_perl_script(
- 'Build.PL', [],
- ['--include_dirs', '/foo' ],
- ) };
-
- ok $mb = Module::Build->resume;
- is_deeply $mb->include_dirs, ['/foo'], 'Should have single include dir';
-}
-
+++ /dev/null
-# sample.t -- a sample test file for Module::Build
-
-use strict;
-use lib 't/lib';
-use MBTest; # or 'no_plan'
-use DistGen;
-use Config;
-use File::Spec;
-use ExtUtils::Packlist;
-use ExtUtils::Installed;
-use File::Path;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-blib_load('Module::Build::ConfigData');
-
-if ( $ENV{PERL_CORE} ) {
- plan skip_all => 'bundle_inc tests will never succeed in PERL_CORE';
-}
-elsif ( ! $ENV{MB_TEST_EXPERIMENTAL} ) {
- plan skip_all => '$ENV{MB_TEST_EXPERIMENTAL} is not set';
-}
-elsif ( ! MBTest::check_EUI() ) {
- plan skip_all => 'ExtUtils::Installed takes too long on your system';
-}
-elsif ( Module::Build::ConfigData->feature('inc_bundling_support') ) {
- plan tests => 19;
-} else {
- plan skip_all => 'inc_bundling_support feature is not enabled';
-}
-
-# need to do a temp install of M::B being tested to ensure a packlist
-# is available for bundling
-
-my $current_mb = Module::Build->resume();
-my $temp_install = MBTest->tmpdir();
-my $arch = $Config{archname};
-my $lib_path = File::Spec->catdir($temp_install,qw/lib perl5/);
-my $arch_path = File::Spec->catdir( $lib_path, $arch );
-mkpath ( $arch_path );
-ok( -d $arch_path, "created temporary M::B pseudo-install directory");
-
-unshift @INC, $lib_path, $arch_path;
-local $ENV{PERL5LIB} = join( $Config{path_sep},
- $lib_path, ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : () )
-);
-
-# must uninst=0 so we don't try to remove an installed M::B!
-stdout_of( sub { $current_mb->dispatch(
- 'install', install_base => $temp_install, uninst => 0
- )
- }
-);
-
-# create dist object in a temp directory
-# enter the directory and generate the skeleton files
-my $dist = DistGen->new( inc => 1 )->chdir_in->regen;
-
-# get a Module::Build object and test with it
-my $mb = $dist->new_from_context(); # quiet by default
-isa_ok( $mb, "Module::Build" );
-is( $mb->dist_name, "Simple", "dist_name is 'Simple'" );
-is_deeply( $mb->bundle_inc, [ 'Module::Build' ],
- "Module::Build is flagged for bundling"
-);
-
-# bundle stuff into distdir
-stdout_stderr_of( sub { $mb->dispatch('distdir') } );
-
-my $dist_inc = File::Spec->catdir($mb->dist_dir, 'inc');
-ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ),
- "dist_dir/inc/latest.pm created"
-);
-
-ok( -d File::Spec->catdir( $dist_inc, 'inc_Module-Build' ),
- "dist_dir/inc/inc_Module_Build created"
-);
-
-my $mb_file =
- File::Spec->catfile( $dist_inc, qw/inc_Module-Build Module Build.pm/ );
-
-ok( -e $mb_file,
- "dist_dir/inc/inc_Module_Build/Module/Build.pm created"
-);
-
-ok( -e File::Spec->catfile( $dist_inc, qw/inc_Module-Build Module Build Base.pm/ ),
- "dist_dir/inc/inc_Module_Build/Module/Build/Base.pm created"
-);
-
-# Force bundled M::B to a higher version so it gets loaded
-# This has failed on Win32 for no known reason, so we'll skip if
-# we can't edit the file.
-
-eval {
- chmod 0666, $mb_file;
- open(my $fh, '<', $mb_file) or die "Could not read $mb_file: $!";
- my $mb_code = do { local $/; <$fh> };
- $mb_code =~ s{\$VERSION\s+=\s+\S+}{\$VERSION = 9999;};
- close $fh;
- open($fh, '>', $mb_file) or die "Could not write $mb_file: $!";
- print {$fh} $mb_code;
- close $fh;
-};
-
-my $err = $@;
-diag $@ if $@;
-SKIP: {
- skip "Couldn't adjust \$VERSION in bundled M::B for testing", 10
- if $err;
-
- # test the bundling in dist_dir
- chdir $mb->dist_dir;
-
- stdout_of( sub { Module::Build->run_perl_script('Build.PL',[],[]) } );
- ok( -e 'MYMETA.yml', 'MYMETA was created' );
-
- open(my $meta, '<', 'MYMETA.yml');
- ok( $meta, "opened MYMETA.yml" );
- ok( scalar( grep { /generated_by:.*9999/ } <$meta> ),
- "dist_dir Build.PL loaded bundled Module::Build"
- );
- close $meta;
-
- #--------------------------------------------------------------------------#
- # test identification of dependencies
- #--------------------------------------------------------------------------#
-
- $dist->chdir_in;
-
- $dist->add_file( 'mylib/Foo.pm', << 'HERE' );
-package Foo;
-our $VERSION = 1;
-1;
-HERE
-
- $dist->add_file( 'mylib/Bar.pm', << 'HERE' );
-package Bar;
-use Foo;
-our $VERSION = 42;
-1;
-HERE
-
- $dist->change_file( 'Build.PL', << "HERE" );
-use inc::latest 'Module::Build';
-use inc::latest 'Foo';
-
-Module::Build->new(
- module_name => '$dist->{name}',
- license => 'perl',
-)->create_build_script;
-HERE
-
- $dist->regen( clean => 1 );
-
- make_packlist($_,'mylib') for qw/Foo Bar/;
-
- # get a Module::Build object and test with it
- my $abs_mylib = File::Spec->rel2abs('mylib');
-
-
- unshift @INC, $abs_mylib;
- $mb = $dist->new_from_context(); # quiet by default
- isa_ok( $mb, "Module::Build" );
- is_deeply( [sort @{$mb->bundle_inc}], [ 'Foo', 'Module::Build' ],
- "Module::Build and Foo are flagged for bundling"
- );
-
- my $output = stdout_stderr_of( sub { $mb->dispatch('distdir') } );
-
- ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ),
- "./inc/latest.pm created"
- );
-
- ok( -d File::Spec->catdir( $dist_inc, 'inc_Foo' ),
- "dist_dir/inc/inc_Foo created"
- );
-
- $dist->change_file( 'Build.PL', << "HERE" );
-use inc::latest 'Module::Build';
-use inc::latest 'Bar';
-
-Module::Build->new(
- module_name => '$dist->{name}',
- license => 'perl',
-)->create_build_script;
-HERE
-
- $dist->regen( clean => 1 );
- make_packlist($_,'mylib') for qw/Foo Bar/;
-
- $mb = $dist->new_from_context(); # quiet by default
- isa_ok( $mb, "Module::Build" );
- is_deeply( [sort @{$mb->bundle_inc}], [ 'Bar', 'Module::Build' ],
- "Module::Build and Bar are flagged for bundling"
- );
-
- $output = stdout_stderr_of( sub { $mb->dispatch('distdir') } );
-
- ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ),
- "./inc/latest.pm created"
- );
-
- ok( -d File::Spec->catdir( $dist_inc, 'inc_Bar' ),
- "dist_dir/inc/inc_Bar created"
- );
-}
-
-
-sub make_packlist {
- my ($mod, $lib) = @_;
- my $arch = $Config{archname};
- (my $mod_path = $mod) =~ s{::}{/}g;
- my $mod_file = File::Spec->catfile( $lib, "$mod_path\.pm" );
- my $abs = File::Spec->rel2abs($mod_file);
- my $packlist_path = File::Spec->catdir($lib, $arch, 'auto', $mod_path);
- mkpath $packlist_path;
- my $packlist = ExtUtils::Packlist->new;
- $packlist->{$abs}++;
- $packlist->write( File::Spec->catfile( $packlist_path, '.packlist' ));
-}
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-# Modified from the original as a "mock" version for testing
-use strict;
-use warnings;
-use 5.006; # warnings
-package Software::License;
-our $VERSION = 9999;
-
-sub new {
- my ($class, $arg) = @_;
-
- # XXX changed from Carp::croak to die
- die "no copyright holder specified" unless $arg->{holder};
-
- bless $arg => $class;
-}
-
-
-sub year { defined $_[0]->{year} ? $_[0]->{year} : (localtime)[5]+1900 }
-sub holder { $_[0]->{holder} }
-
-sub version {
- my ($self) = @_;
- my $pkg = ref $self ? ref $self : $self;
- $pkg =~ s/.+:://;
- my (undef, @vparts) = split /_/, $pkg;
-
- return unless @vparts;
- return join '.', @vparts;
-}
-
-
-# sub meta1_name { return undef; } # sort this out later, should be easy
-sub meta_name { return undef; }
-sub meta_yml_name { $_[0]->meta_name }
-
-sub meta2_name {
- my ($self) = @_;
- my $meta1 = $self->meta_name;
-
- return undef unless defined $meta1;
-
- return $meta1
- if $meta1 =~ /\A(?:open_source|restricted|unrestricted|unknown)\z/;
-
- return undef;
-}
-
-# XXX these are trivial mocks of the real thing
-sub notice { 'NOTICE' }
-sub license { 'LICENSE' }
-sub fulltext { 'FULLTEXT' }
-
-1;
-
-
-
+++ /dev/null
-#---------------------------------------------------------------------
-package Tie::CPHash;
-#
-# Copyright 1997 Christopher J. Madsen
-#
-# Author: Christopher J. Madsen <cjm@pobox.com>
-# Created: 08 Nov 1997
-# $Revision$ $Date$
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the same terms as Perl itself.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
-# GNU General Public License or the Artistic License for more details.
-#
-# Case preserving but case insensitive hash
-#---------------------------------------------------------------------
-
-require 5.000;
-use strict;
-use vars qw(@ISA $VERSION);
-
-@ISA = qw();
-
-#=====================================================================
-# Package Global Variables:
-
-$VERSION = '1.02';
-
-#=====================================================================
-# Tied Methods:
-#---------------------------------------------------------------------
-# TIEHASH classname
-# The method invoked by the command `tie %hash, classname'.
-# Associates a new hash instance with the specified class.
-
-sub TIEHASH
-{
- bless {}, $_[0];
-} # end TIEHASH
-
-#---------------------------------------------------------------------
-# STORE this, key, value
-# Store datum *value* into *key* for the tied hash *this*.
-
-sub STORE
-{
- $_[0]->{lc $_[1]} = [ $_[1], $_[2] ];
-} # end STORE
-
-#---------------------------------------------------------------------
-# FETCH this, key
-# Retrieve the datum in *key* for the tied hash *this*.
-
-sub FETCH
-{
- my $v = $_[0]->{lc $_[1]};
- ($v ? $v->[1] : undef);
-} # end FETCH
-
-#---------------------------------------------------------------------
-# FIRSTKEY this
-# Return the (key, value) pair for the first key in the hash.
-
-sub FIRSTKEY
-{
- my $a = scalar keys %{$_[0]};
- &NEXTKEY;
-} # end FIRSTKEY
-
-#---------------------------------------------------------------------
-# NEXTKEY this, lastkey
-# Return the next (key, value) pair for the hash.
-
-sub NEXTKEY
-{
- my $v = (each %{$_[0]})[1];
- ($v ? $v->[0] : undef );
-} # end NEXTKEY
-
-#---------------------------------------------------------------------
-# SCALAR this
-# Return bucket usage information for the hash (0 if empty).
-
-sub SCALAR
-{
- scalar %{$_[0]};
-} # end SCALAR
-
-#---------------------------------------------------------------------
-# EXISTS this, key
-# Verify that *key* exists with the tied hash *this*.
-
-sub EXISTS
-{
- exists $_[0]->{lc $_[1]};
-} # end EXISTS
-
-#---------------------------------------------------------------------
-# DELETE this, key
-# Delete the key *key* from the tied hash *this*.
-# Returns the old value, or undef if it didn't exist.
-
-sub DELETE
-{
- my $v = delete $_[0]->{lc $_[1]};
- ($v ? $v->[1] : undef);
-} # end DELETE
-
-#---------------------------------------------------------------------
-# CLEAR this
-# Clear all values from the tied hash *this*.
-
-sub CLEAR
-{
- %{$_[0]} = ();
-} # end CLEAR
-
-#=====================================================================
-# Other Methods:
-#---------------------------------------------------------------------
-# Return the case of KEY.
-
-sub key
-{
- my $v = $_[0]->{lc $_[1]};
- ($v ? $v->[0] : undef);
-}
-
-#=====================================================================
-# Package Return Value:
-
-1;
-
-__END__
-
-=head1 NAME
-
-Tie::CPHash - Case preserving but case insensitive hash table
-
-=head1 SYNOPSIS
-
- require Tie::CPHash;
- tie %cphash, 'Tie::CPHash';
-
- $cphash{'Hello World'} = 'Hi there!';
- printf("The key `%s' was used to store `%s'.\n",
- tied(%cphash)->key('HELLO WORLD'),
- $cphash{'HELLO world'});
-
-=head1 DESCRIPTION
-
-The B<Tie::CPHash> module provides a hash table that is case
-preserving but case insensitive. This means that
-
- $cphash{KEY} $cphash{key}
- $cphash{Key} $cphash{keY}
-
-all refer to the same entry. Also, the hash remembers which form of
-the key was last used to store the entry. The C<keys> and C<each>
-functions will return the key that was used to set the value.
-
-An example should make this clear:
-
- tie %h, 'Tie::CPHash';
- $h{Hello} = 'World';
- print $h{HELLO}; # Prints 'World'
- print keys(%h); # Prints 'Hello'
- $h{HELLO} = 'WORLD';
- print $h{hello}; # Prints 'WORLD'
- print keys(%h); # Prints 'HELLO'
-
-The additional C<key> method lets you fetch the case of a specific key:
-
- # When run after the previous example, this prints 'HELLO':
- print tied(%h)->key('Hello');
-
-(The C<tied> function returns the object that C<%h> is tied to.)
-
-If you need a case insensitive hash, but don't need to preserve case,
-just use C<$hash{lc $key}> instead of C<$hash{$key}>. This has a lot
-less overhead than B<Tie::CPHash>.
-
-=head1 AUTHOR
-
-Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt>
-
-=cut
-
-# Local Variables:
-# tmtrack-file-task: "Tie::CPHash.pm"
-# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use File::Spec;
-use Config;
-
-# Don't let our own verbosity/test_file get mixed up with our subprocess's
-my @makefile_keys = qw(TEST_VERBOSE HARNESS_VERBOSE TEST_FILES MAKEFLAGS);
-local @ENV{@makefile_keys};
-delete @ENV{@makefile_keys};
-
-my @makefile_types = qw(small passthrough traditional);
-my $tests_per_type = 15;
-
-#find_in_path does not understand VMS.
-
-if ( $Config{make} && $^O ne 'VMS' ? find_in_path($Config{make}) : 1 ) {
- plan 'no_plan';
-} else {
- plan skip_all => "Don't know how to invoke 'make'";
-}
-
-my $is_vms_mms = ($^O eq 'VMS') && ($Config{make} =~ /MM[SK]/i);
-
-blib_load('Module::Build');
-blib_load('Module::Build::Version');
-
-
-#########################
-
-my $tmp = MBTest->tmpdir;
-
-# Create test distribution; set requires and build_requires
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-$dist->chdir_in;
-
-
-#########################
-
-blib_load('Module::Build');
-blib_load('Module::Build::Compat');
-
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
-
-my @make = $Config{make} eq 'nmake' ? ('nmake', '-nologo') : ($Config{make});
-
-my $makefile = 'Makefile';
-
-# VMS MMK/MMS by convention use Descrip.MMS
-if ($is_vms_mms) {
- $makefile = 'Descrip.MMS';
-}
-
-
-#########################
-
-# Test without requires
-
-test_makefile_types();
-
-# Test with requires and PL_files
-
-my $distname = $dist->name;
-$dist->change_build_pl({
- module_name => $distname,
- license => 'perl',
- requires => {
- 'perl' => $],
- 'File::Spec' => 0.2,
- },
- build_requires => {
- 'Test::More' => 0,
- 'File::Spec' => 0,
- },
- PL_files => { 'foo.PL' => 'foo' },
-});
-
-$dist->add_file("foo.PL", <<'END');
-open my $fh, ">$ARGV[0]" or die $!;
-print $fh "foo\n";
-END
-
-$dist->regen;
-
-test_makefile_types(
- requires => {
- 'perl' => $],
- 'File::Spec' => 0.2,
- },
- build_requires => {
- 'Test::More' => 0,
- 'File::Spec' => 0,
- },
- PL_files => {
- 'foo.PL' => 'foo',
- },
-);
-
-######################
-
-$dist->change_build_pl({
- module_name => $distname,
- license => 'perl',
-});
-$dist->regen;
-
-# Create M::B instance but don't pollute STDOUT
-my $mb;
-stdout_stderr_of( sub {
- $mb = Module::Build->new_from_context;
-});
-ok $mb, "Module::Build->new_from_context";
-
-
-{
- # Make sure fake_makefile() can run without 'build_class', as it may be
- # in older-generated Makefile.PLs
- my $warning = '';
- local $SIG{__WARN__} = sub { $warning = shift; };
-
- my $maketext = eval { Module::Build::Compat->fake_makefile(makefile => $makefile) };
- is $@, '', "fake_makefile lived";
- like $maketext, qr/^realclean/m, "found 'realclean' in fake_makefile output";
- like $warning, qr/build_class/, "saw warning about 'build_class'";
-}
-
-{
- # Make sure custom builder subclass is used in the created
- # Makefile.PL - make sure it fails in the right way here.
- local @Foo::Builder::ISA = qw(Module::Build);
- my $foo_builder;
- stdout_stderr_of( sub {
- $foo_builder = Foo::Builder->new_from_context;
- });
- foreach my $style ('passthrough', 'small') {
- create_makefile_pl($style, $foo_builder);
-
- # Should fail with "can't find Foo/Builder.pm"
- my $result;
- my ($stdout, $stderr ) = stdout_stderr_of (sub {
- $result = $mb->run_perl_script('Makefile.PL');
- });
- ok ! $result, "Makefile.PL failed";
- like $stderr, qr{Foo/Builder.pm}, "custom builder wasn't found";
- }
-
- # Now make sure it can actually work.
- my $bar_builder;
- stdout_stderr_of( sub {
- $bar_builder = Module::Build->subclass( class => 'Bar::Builder' )->new_from_context;
- });
- foreach my $style ('passthrough', 'small') {
- create_makefile_pl($style, $bar_builder);
- my $result;
- stdout_stderr_of( sub {
- $result = $mb->run_perl_script('Makefile.PL');
- });
- ok $result, "Makefile.PL ran without error";
- }
-}
-
-{
- # Make sure various Makefile.PL arguments are supported
- create_makefile_pl('passthrough', $mb);
-
- my $libdir = File::Spec->catdir( $tmp, 'libdir' );
- my $result;
- stdout_stderr_of( sub {
- $result = $mb->run_perl_script('Makefile.PL', [],
- [
- "LIB=$libdir",
- 'TEST_VERBOSE=1',
- 'INSTALLDIRS=perl',
- 'POLLUTE=1',
- ]
- );
- });
- ok $result, "passthrough Makefile.PL ran with arguments";
- ok -e 'Build.PL', "Build.PL generated";
-
- my $new_build = Module::Build->resume();
- is $new_build->installdirs, 'core', "installdirs is core";
- is $new_build->verbose, 1, "tests set for verbose";
- is $new_build->install_destination('lib'), $libdir, "custom libdir";
- is $new_build->extra_compiler_flags->[0], '-DPERL_POLLUTE', "PERL_POLLUTE set";
-
- # Make sure those switches actually had an effect
- my ($ran_ok, $output);
- $output = stdout_stderr_of( sub { $ran_ok = $new_build->do_system(@make, 'test') } );
- ok $ran_ok, "make test ran without error";
- $output =~ s/^/# /gm; # Don't confuse our own test output
- like $output, qr/(?:# ok \d+\s+)+/, 'Should be verbose';
-
- # Make sure various Makefile arguments are supported
- my $make_macro = 'TEST_VERBOSE=0';
-
- # VMS MMK/MMS macros use different syntax.
- if ($is_vms_mms) {
- $make_macro = '/macro=("' . $make_macro . '")';
- }
-
- $output = stdout_stderr_of( sub {
- local $ENV{HARNESS_TIMER}; # RT#39635 - timer messes with output
- $ran_ok = $mb->do_system(@make, 'test', $make_macro)
- } );
-
- ok $ran_ok, "make test without verbose ran ok";
- $output =~ s/^/# /gm; # Don't confuse our own test output
- like $output,
- qr/# .+basic(\.t)?[.\s#]+ok[.\s#]+All tests successful/,
- 'Should be non-verbose';
-
- (my $libdir2 = $libdir) =~ s/libdir/lbiidr/;
- my $libarch2 = File::Spec->catdir($libdir2, 'arch');
- my $check_base = $libdir2;
- $check_base =~ s/\]\z// if $^O eq 'VMS'; # trim trailing ] for appending other dirs
-
- SKIP: {
- my @cases = (
- {
- label => "INSTALLDIRS=vendor",
- args => [ 'INSTALLDIRS=vendor', "INSTALLVENDORLIB=$libdir2", "INSTALLVENDORARCH=$libarch2"],
- check => qr/\Q$check_base\E .* Simple\.pm/ix,
- },
- {
- label => "PREFIX=\$libdir2",
- args => [ "PREFIX=$libdir2"],
- check => qr/\Q$check_base\E .* Simple\.pm/ix,
- },
- {
- label => "PREFIX=\$libdir2 LIB=mylib",
- args => [ "PREFIX=$libdir2", "LIB=mylib" ],
- check => qr{\Q$check_base\E[/\\\.]mylib[/\\\]]Simple\.pm}ix,
- },
- );
-
- require ExtUtils::Install;
- skip "Needs ExtUtils::Install 1.32 or later", 2 * @cases
- if ExtUtils::Install->VERSION < 1.32;
-
- for my $c (@cases) {
- my @make_args = @{$c->{args}};
- ($output) = stdout_stderr_of(
- sub {
- $result = $mb->run_perl_script('Makefile.PL', [], \@make_args);
- $ran_ok = $mb->do_system(@make, 'fakeinstall');
- }
- );
-
- ok $ran_ok, "fakeinstall $c->{label} ran ok";
- $output =~ s/^/# /gm; # Don't confuse our own test output
- like $output, $c->{check},
- "Saw destination directory for $c->{label}";
- }
- }
-
- stdout_stderr_of( sub { $mb->do_system(@make, 'realclean'); } );
- ok ! -e $makefile, "$makefile shouldn't exist";
-
- 1 while unlink 'Makefile.PL';
- ok ! -e 'Makefile.PL', "Makefile.PL cleaned up";
-
- 1 while unlink $libdir, $libdir2;
-}
-
-{ # Make sure tilde-expansion works
-
- # C<glob> on MSWin32 uses $ENV{HOME} if defined to do tilde-expansion
- local $ENV{HOME} = 'C:/' if $^O =~ /MSWin/ && !exists( $ENV{HOME} );
-
- create_makefile_pl('passthrough', $mb);
-
- stdout_stderr_of( sub {
- $mb->run_perl_script('Makefile.PL', [], ['INSTALL_BASE=~/foo']);
- });
- my $b2 = Module::Build->current;
- ok $b2->install_base, "install_base set";
- unlike $b2->install_base, qr/^~/, "Tildes should be expanded";
-
- stdout_stderr_of( sub { $mb->do_system(@make, 'realclean'); } );
- ok ! -e $makefile, "$makefile shouldn't exist";
-
- 1 while unlink 'Makefile.PL';
- ok ! -e 'Makefile.PL', "Makefile.PL cleaned up";
-}
-
-{
- $dist->add_file('t/deep/foo.t', q{});
- $dist->regen;
-
- my $mb;
- stdout_stderr_of( sub {
- $mb = Module::Build->new_from_context( recursive_test_files => 1 );
- });
-
- create_makefile_pl('traditional', $mb);
- my $args = extract_writemakefile_args() || {};
-
- if ( exists $args->{test}->{TESTS} ) {
- is $args->{test}->{TESTS},
- join( q{ },
- File::Spec->catfile(qw(t *.t)),
- File::Spec->catfile(qw(t deep *.t))
- ),
- 'Makefile.PL has correct TESTS line for recursive test files';
- } else {
- ok( ! exists $args->{TESTS}, 'Not using incorrect recursive tests key' );
- }
-
- 1 while unlink 'Makefile.PL';
- ok ! -e 'Makefile.PL', "Makefile.PL cleaned up";
-}
-
-{
- # make sure using prereq with '0.1.2' complains
- $dist->change_build_pl({
- module_name => $distname,
- license => 'perl',
- requires => {
- 'Foo::Frobnicate' => '0.1.2',
- },
- create_makefile_pl => 'traditional',
- });
- $dist->regen;
-
- my $mb;
- stdout_stderr_of( sub {
- $mb = Module::Build->new_from_context;
- });
-
- my $output = stdout_stderr_of( sub { $mb->do_create_makefile_pl } );
- ok -e 'Makefile.PL', "Makefile.PL created";
- like $output, qr/is not portable/, "Correctly complains and converts dotted-decimal";
-
- my $file_contents = slurp 'Makefile.PL';
- like $file_contents, qr/Foo::Frobnicate.+0\.001002/, "Properly converted dotted-decimal";
-
- 1 while unlink 'Makefile.PL';
- ok ! -e 'Makefile.PL', "Makefile.PL cleaned up";
-}
-
-{
- # make sure using invalid prereq blows up
- $dist->change_build_pl({
- module_name => $distname,
- license => 'perl',
- requires => {
- 'Foo::Frobnicate' => '3.5_2_7',
- },
- create_makefile_pl => 'traditional',
- });
- $dist->regen;
-
- ok ! -e 'Makefile.PL', "Makefile.PL doesn't exist before we start";
-
- my $mb;
- stdout_stderr_of( sub {
- $mb = $dist->run_build_pl;
- });
-
- my ($output, $error) = stdout_stderr_of( sub { $dist->run_build('distmeta') } );
- like $error, qr/is not supported/ms, "Correctly dies when it encounters invalid prereq";
- ok ! -e 'Makefile.PL', "Makefile.PL NOT created";
-
- 1 while unlink 'Makefile.PL';
- ok ! -e 'Makefile.PL', "Makefile.PL cleaned up";
-}
-
-#########################################################
-
-sub _merge_prereqs {
- my ($first, $second) = @_;
- my $new = { %$first };
- for my $k (keys %$second) {
- if ( exists $new->{$k} ) {
- my ($v1,$v2) = ($new->{$k},$second->{$k});
- $new->{$k} = ($v1 > $v2 ? $v1 : $v2);
- }
- else {
- $new->{$k} = $second->{$k};
- }
- }
- return $new;
-}
-
-sub test_makefile_types {
- my %opts = @_;
- $opts{requires} ||= {};
- $opts{build_requires} ||= {};
- $opts{PL_files} ||= {};
-
- foreach my $type (@makefile_types) {
- # Create M::B instance
- my $mb;
- stdout_stderr_of( sub {
- $mb = Module::Build->new_from_context;
- });
- ok $mb, "Module::Build->new_from_context";
-
- # Create and test Makefile.PL
- create_makefile_pl($type, $mb);
-
- test_makefile_pl_requires_perl( $opts{requires}{perl} );
- test_makefile_creation($mb);
- test_makefile_prereq_pm( _merge_prereqs($opts{requires}, $opts{build_requires}) );
- test_makefile_pl_files( $opts{PL_files} ) if $type eq 'traditional';
-
- my ($output,$success);
- # Capture output to keep our STDOUT clean
- $output = stdout_stderr_of( sub {
- $success = $mb->do_system(@make);
- });
- ok $success, "make ran without error";
-
- for my $file (values %{ $opts{PL_files} }) {
- ok -e $file, "PL_files generated - $file";
- }
-
- # Can't let 'test' STDOUT go to our STDOUT, or it'll confuse Test::Harness.
- $output = stdout_stderr_of( sub {
- $success = $mb->do_system(@make, 'test');
- });
- ok $success, "make test ran without error";
- like uc $output, qr{DONE\.|SUCCESS}, "make test output indicated success";
-
- $output = stdout_stderr_of( sub {
- $success = $mb->do_system(@make, 'realclean');
- });
- ok $success, "make realclean ran without error";
-
- # Try again with some Makefile.PL arguments
- test_makefile_creation($mb, [], 'INSTALLDIRS=vendor', 'realclean');
-
- # Try again using distclean
- test_makefile_creation($mb, [], '', 'distclean');
-
- 1 while unlink 'Makefile.PL';
- ok ! -e 'Makefile.PL', "cleaned up Makefile";
- }
-}
-
-sub test_makefile_creation {
- my ($build, $preargs, $postargs, $cleanup) = @_;
-
- my ($output, $result);
- # capture output to avoid polluting our test output
- $output = stdout_stderr_of( sub {
- $result = $build->run_perl_script('Makefile.PL', $preargs, $postargs);
- });
- my $label = "Makefile.PL ran without error";
- if ( defined $postargs && length $postargs ) {
- $label .= " (postargs: $postargs)";
- }
- ok $result, $label;
- ok -e $makefile, "$makefile exists";
-
- if ($cleanup) {
- # default to 'realclean' unless we recognize the clean method
- $cleanup = 'realclean' unless $cleanup =~ /^(dist|real)clean$/;
- my ($stdout, $stderr ) = stdout_stderr_of (sub {
- $build->do_system(@make, $cleanup);
- });
- ok ! -e $makefile, "$makefile cleaned up with $cleanup";
- }
- else {
- pass '(skipping cleanup)'; # keep test count constant
- }
-}
-
-sub test_makefile_prereq_pm {
- my %requires = %{ $_[0] };
- delete $requires{perl}; # until EU::MM supports this
- SKIP: {
- skip "$makefile not found", 1 unless -e $makefile;
- my $prereq_pm = find_params_in_makefile()->{PREREQ_PM} || {};
- is_deeply $prereq_pm, \%requires,
- "$makefile has correct PREREQ_PM line";
- }
-}
-
-sub test_makefile_pl_files {
- my $expected = shift;
-
- SKIP: {
- skip 1, 'Makefile.PL not found' unless -e 'Makefile.PL';
- my $args = extract_writemakefile_args() || {};
- is_deeply $args->{PL_FILES}, $expected,
- "Makefile.PL has correct PL_FILES line";
- }
-}
-
-sub test_makefile_pl_requires_perl {
- my $perl_version = shift || q{};
- SKIP: {
- skip 1, 'Makefile.PL not found' unless -e 'Makefile.PL';
- my $file_contents = slurp 'Makefile.PL';
- my $found_requires = $file_contents =~ m{^require $perl_version;}ms;
- if (length $perl_version) {
- ok $found_requires, "Makefile.PL has 'require $perl_version;'"
- or diag "Makefile.PL:\n$file_contents";
- }
- else {
- ok ! $found_requires, "Makefile.PL does not require a perl version";
- }
- }
-}
-
-sub find_params_in_makefile {
- open(my $fh, '<', $makefile )
- or die "Can't read $makefile: $!";
- local($/) = "\n";
-
- my %params;
- while (<$fh>) {
- # Blank line after params.
- last if keys %params and !/\S+/;
-
- next unless m{^\# \s+ ( [A-Z_]+ ) \s+ => \s+ ( .* )$}x;
-
- my($key, $val) = ($1, $2);
- # extract keys and values
- while ( $val =~ m/(?:\s)(\S+)=>(q\[.*?\]|undef),?/g ) {
- my($m,$n) = ($1,$2);
- if ($n =~ /^q\[(.*?)\]$/) {
- $n = $1;
- }
- $params{$key}{$m} = $n;
- }
- }
-
- return \%params;
-}
-
-sub extract_writemakefile_args {
- SKIP: {
- skip 1, 'Makefile.PL not found' unless -e 'Makefile.PL';
- my $file_contents = slurp 'Makefile.PL';
- my ($args) = $file_contents =~ m{^WriteMakefile\n\((.*)\).*;}ms;
- ok $args, "Found WriteMakefile arguments"
- or diag "Makefile.PL:\n$file_contents";
- my %args = eval $args or diag $args; ## no critic
- return \%args;
- }
-}
-
-sub create_makefile_pl {
- my @args = @_;
- stdout_stderr_of( sub { Module::Build::Compat->create_makefile_pl(@args) } );
- my $ok = ok -e 'Makefile.PL', "$_[0] Makefile.PL created";
-
- # Some really conservative make's, like HP/UX, assume files with the same
- # timestamp are out of date. Send the Makefile.PL one second into the past
- # so its older than the Makefile it will generate.
- # See [rt.cpan.org 45700]
- my $mtime = (stat("Makefile.PL"))[9];
- utime $mtime, $mtime - 1, "Makefile.PL";
-
- return $ok;
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-
-use lib 't/lib';
-use MBTest tests => 3;
-
-blib_load('Module::Build');
-
-#########################
-
-my $tmp = MBTest->tmpdir;
-
-# Create test distribution; set requires and build_requires
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-
-$dist->regen;
-
-$dist->chdir_in;
-
-#########################
-
-my $mb; stdout_of(sub{ $mb = Module::Build->new_from_context});
-
-blib_load('Module::Build::Compat');
-
-$dist->regen;
-
-stdout_stderr_of(
- sub{ Module::Build::Compat->create_makefile_pl('passthrough', $mb); }
-);
-
-# as silly as all of this exit(0) business is, that is what the cpan
-# testers have instructed everybody to do so...
-$dist->change_file('Build.PL' =>
- "warn qq(you have no libthbbt\n); exit;\n" . $dist->get_file('Build.PL')
-);
-
-$dist->regen;
-
-stdout_of(sub{ $mb->ACTION_realclean });
-
-my $result;
-my ($stdout, $stderr ) = stdout_stderr_of (sub {
- $result = $mb->run_perl_script('Makefile.PL');
-});
-ok $result, "Makefile.PL exit";
-like $stdout, qr/running Build\.PL/;
-like $stderr, qr/you have no libthbbt$/;
-#warn "out: $stdout"; warn "err: $stderr";
-
-# vim:ts=2:sw=2:et:sta
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 1;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-$dist->chdir_in;
-
-#########################
-
-# Test debug output
-{
- my $output;
- $output = stdout_of sub { $dist->run_build_pl };
- $output = stdout_of sub { $dist->run_build('--debug') };
- like($output, '/Starting ACTION_build.*?Starting ACTION_code.*?Finished ACTION_code.*?Finished ACTION_build/ms',
- "found nested ACTION_* debug statements"
- );
-}
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 113;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-$dist->chdir_in;
-
-
-use Config;
-use File::Spec::Functions qw( catdir splitdir splitpath );
-
-#########################
-
-# We need to create a well defined environment to test install paths.
-# We do this by setting up appropriate Config entries.
-
-my @installstyle = qw(lib perl5);
-my $mb = Module::Build->new_from_context(
- installdirs => 'site',
- config => {
- installstyle => catdir(@installstyle),
-
- installprivlib => catdir($tmp, @installstyle),
- installarchlib => catdir($tmp, @installstyle,
- @Config{qw(version archname)}),
- installbin => catdir($tmp, 'bin'),
- installscript => catdir($tmp, 'bin'),
- installman1dir => catdir($tmp, 'man', 'man1'),
- installman3dir => catdir($tmp, 'man', 'man3'),
- installhtml1dir => catdir($tmp, 'html'),
- installhtml3dir => catdir($tmp, 'html'),
-
- installsitelib => catdir($tmp, 'site', @installstyle, 'site_perl'),
- installsitearch => catdir($tmp, 'site', @installstyle, 'site_perl',
- @Config{qw(version archname)}),
- installsitebin => catdir($tmp, 'site', 'bin'),
- installsitescript => catdir($tmp, 'site', 'bin'),
- installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'),
- installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'),
- installsitehtml1dir => catdir($tmp, 'site', 'html'),
- installsitehtml3dir => catdir($tmp, 'site', 'html'),
- }
-);
-isa_ok( $mb, 'Module::Build::Base' );
-
-# Get us into a known state.
-$mb->install_base(undef);
-$mb->prefix(undef);
-
-
-# Check install_path() accessor
-{
- my( $map, $path );
-
- $map = $mb->install_path();
- is_deeply( $map, {}, 'install_path() accessor' );
-
- $path = $mb->install_path('elem' => '/foo/bar');
- is( $path, '/foo/bar', ' returns assigned path' );
-
- $path = $mb->install_path('elem');
- is( $path, '/foo/bar', ' can read stored path' );
-
- $map = $mb->install_path();
- is_deeply( $map, { 'elem' => '/foo/bar' }, ' can access map' );
-
- $path = $mb->install_path('elem' => undef);
- is( $path, undef, ' can delete a path element' );
-
- $map = $mb->install_path();
- is_deeply( $map, {}, ' deletes path from map' );
-}
-
-# Check install_base_relpaths() accessor
-{
- my( $map, $path );
-
- $map = $mb->install_base_relpaths();
- is( ref($map), 'HASH', 'install_base_relpaths() accessor' );
-
- eval{ $path = $mb->install_base_relpaths('elem' => '/foo/bar') };
- like( $@, qr/Value must be a relative path/, ' emits error if path not relative' );
-
- $path = $mb->install_base_relpaths('elem' => 'foo/bar');
- is( $path, catdir(qw(foo bar)), ' returns assigned path' );
-
- $path = $mb->install_base_relpaths('elem');
- is( $path, catdir(qw(foo/bar)), ' can read stored path' );
-
- $map = $mb->install_base_relpaths();
- is_deeply( $map->{elem}, [qw(foo bar)], ' can access map' );
-
- $path = $mb->install_base_relpaths('elem' => undef);
- is( $path, undef, ' can delete a path element' );
-
- $map = $mb->install_base_relpaths();
- is( $map->{elem}, undef, ' deletes path from map' );
-}
-
-# Check prefix_relpaths() accessor
-{
- my( $map, $path );
-
- $map = $mb->prefix_relpaths();
- is( ref($map), 'HASH', 'prefix_relpaths() accessor' );
-
- is_deeply( $mb->prefix_relpaths(), $mb->prefix_relpaths('site'),
- ' defaults to \'site\'' );
-
- eval{ $path = $mb->prefix_relpaths('site', 'elem' => '/foo/bar') };
- like( $@, qr/Value must be a relative path/, ' emits error if path not relative' );
-
- $path = $mb->prefix_relpaths('site', 'elem' => 'foo/bar');
- is( $path, catdir(qw(foo bar)), ' returns assigned path' );
-
- $path = $mb->prefix_relpaths('site', 'elem');
- is( $path, catdir(qw(foo bar)), ' can read stored path' );
-
- $map = $mb->prefix_relpaths();
- is_deeply( $map->{elem}, [qw(foo bar)], ' can access map' );
-
- $path = $mb->prefix_relpaths('site', 'elem' => undef);
- is( $path, undef, ' can delete a path element' );
-
- $map = $mb->prefix_relpaths();
- is( $map->{elem}, undef, ' deletes path from map' );
-}
-
-
-# Check that we install into the proper default locations.
-{
- is( $mb->installdirs, 'site' );
- is( $mb->install_base, undef );
- is( $mb->prefix, undef );
-
- test_install_destinations( $mb, {
- lib => catdir($tmp, 'site', @installstyle, 'site_perl'),
- arch => catdir($tmp, 'site', @installstyle, 'site_perl',
- @Config{qw(version archname)}),
- bin => catdir($tmp, 'site', 'bin'),
- script => catdir($tmp, 'site', 'bin'),
- bindoc => catdir($tmp, 'site', 'man', 'man1'),
- libdoc => catdir($tmp, 'site', 'man', 'man3'),
- binhtml => catdir($tmp, 'site', 'html'),
- libhtml => catdir($tmp, 'site', 'html'),
- });
-}
-
-
-# Is installdirs honored?
-{
- $mb->installdirs('core');
- is( $mb->installdirs, 'core' );
-
- test_install_destinations( $mb, {
- lib => catdir($tmp, @installstyle),
- arch => catdir($tmp, @installstyle, @Config{qw(version archname)}),
- bin => catdir($tmp, 'bin'),
- script => catdir($tmp, 'bin'),
- bindoc => catdir($tmp, 'man', 'man1'),
- libdoc => catdir($tmp, 'man', 'man3'),
- binhtml => catdir($tmp, 'html'),
- libhtml => catdir($tmp, 'html'),
- });
-
- $mb->installdirs('site');
- is( $mb->installdirs, 'site' );
-}
-
-
-# Check install_base()
-{
- my $install_base = catdir( 'foo', 'bar' );
- $mb->install_base( $install_base );
-
- is( $mb->prefix, undef );
- is( $mb->install_base, $install_base );
-
-
- test_install_destinations( $mb, {
- lib => catdir( $install_base, 'lib', 'perl5' ),
- arch => catdir( $install_base, 'lib', 'perl5', $Config{archname} ),
- bin => catdir( $install_base, 'bin' ),
- script => catdir( $install_base, 'bin' ),
- bindoc => catdir( $install_base, 'man', 'man1'),
- libdoc => catdir( $install_base, 'man', 'man3' ),
- binhtml => catdir( $install_base, 'html' ),
- libhtml => catdir( $install_base, 'html' ),
- });
-}
-
-
-# Basic prefix test. Ensure everything is under the prefix.
-{
- $mb->install_base( undef );
- ok( !defined $mb->install_base );
-
- my $prefix = catdir( qw( some prefix ) );
- $mb->prefix( $prefix );
- is( $mb->{properties}{prefix}, $prefix );
-
- test_prefix($prefix, $mb->install_sets('site'));
-}
-
-
-# And now that prefix honors installdirs.
-{
- $mb->installdirs('core');
- is( $mb->installdirs, 'core' );
-
- my $prefix = catdir( qw( some prefix ) );
- test_prefix($prefix);
-
- $mb->installdirs('site');
- is( $mb->installdirs, 'site' );
-}
-
-
-# Try a config setting which would result in installation locations outside
-# the prefix. Ensure it doesn't.
-{
- # Get the prefix defaults
- my $defaults = $mb->prefix_relpaths('site');
-
- # Create a configuration involving weird paths that are outside of
- # the configured prefix.
- my @prefixes = (
- [qw(foo bar)],
- [qw(biz)],
- [],
- );
-
- my %test_config;
- foreach my $type (keys %$defaults) {
- my $prefix = shift @prefixes || [qw(foo bar)];
- $test_config{$type} = catdir(File::Spec->rootdir, @$prefix,
- @{$defaults->{$type}});
- }
-
- # Poke at the innards of MB to change the default install locations.
- my $old = $mb->install_sets->{site};
- $mb->install_sets->{site} = \%test_config;
- $mb->config(siteprefixexp => catdir(File::Spec->rootdir,
- 'wierd', 'prefix'));
-
- my $prefix = catdir('another', 'prefix');
- $mb->prefix($prefix);
- test_prefix($prefix, \%test_config);
- $mb->install_sets->{site} = $old;
-}
-
-
-# Check that we can use install_base after setting prefix.
-{
- my $install_base = catdir( 'foo', 'bar' );
- $mb->install_base( $install_base );
-
- test_install_destinations( $mb, {
- lib => catdir( $install_base, 'lib', 'perl5' ),
- arch => catdir( $install_base, 'lib', 'perl5', $Config{archname} ),
- bin => catdir( $install_base, 'bin' ),
- script => catdir( $install_base, 'bin' ),
- bindoc => catdir( $install_base, 'man', 'man1'),
- libdoc => catdir( $install_base, 'man', 'man3' ),
- binhtml => catdir( $install_base, 'html' ),
- libhtml => catdir( $install_base, 'html' ),
- });
-}
-
-
-sub test_prefix {
- my ($prefix, $test_config) = @_;
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- foreach my $type (qw(lib arch bin script bindoc libdoc binhtml libhtml)) {
- my $dest = $mb->install_destination( $type );
- ok $mb->dir_contains($prefix, $dest), "$type prefixed";
-
- SKIP: {
- skip( "'$type' not configured", 1 )
- unless $test_config && $test_config->{$type};
-
- have_same_ending( $dest, $test_config->{$type},
- " suffix correctish " .
- "($test_config->{$type} + $prefix = $dest)" );
- }
- }
-}
-
-sub have_same_ending {
- my ($dir1, $dir2, $message) = @_;
-
- $dir1 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash
- my (undef, $dirs1, undef) = splitpath $dir1;
- my @dir1 = splitdir $dirs1;
-
- $dir2 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash
- my (undef, $dirs2, undef) = splitpath $dir2;
- my @dir2 = splitdir $dirs2;
-
- is $dir1[-1], $dir2[-1], $message;
-}
-
-sub test_install_destinations {
- my($build, $expect) = @_;
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- while( my($type, $expect) = each %$expect ) {
- is( $build->install_destination($type), $expect, "$type destination" );
- }
-}
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest;
-
-my @unix_splits =
- (
- { q{one t'wo th'ree f"o\"ur " "five" } => [ 'one', 'two three', 'fo"ur ', 'five' ] },
- { q{ foo bar } => [ 'foo', 'bar' ] },
- { q{ D\'oh f\{g\'h\"i\]\* } => [ "D'oh", "f{g'h\"i]*" ] },
- { q{ D\$foo } => [ 'D$foo' ] },
- { qq{one\\\ntwo} => [ "one\ntwo" ] }, # TODO
- );
-
-my @win_splits =
- (
- { 'a" "b\\c" "d' => [ 'a b\c d' ] },
- { '"a b\\c d"' => [ 'a b\c d' ] },
- { '"a b"\\"c d"' => [ 'a b"c', 'd' ] },
- { '"a b"\\\\"c d"' => [ 'a b\c d' ] },
- { '"a"\\"b" "a\\"b"' => [ 'a"b a"b' ] },
- { '"a"\\\\"b" "a\\\\"b"' => [ 'a\b', 'a\b' ] },
- { '"a"\\"b a\\"b"' => [ 'a"b', 'a"b' ] },
- { 'a"\\"b" "a\\"b' => [ 'a"b', 'a"b' ] },
- { 'a"\\"b" "a\\"b' => [ 'a"b', 'a"b' ] },
- { 'a b' => [ 'a', 'b' ] },
- { 'a"\\"b a\\"b' => [ 'a"b a"b' ] },
- { '"a""b" "a"b"' => [ 'a"b ab' ] },
- { '\\"a\\"' => [ '"a"' ] },
- { '"a"" "b"' => [ 'a"', 'b' ] },
- { 'a"b' => [ 'ab' ] },
- { 'a""b' => [ 'ab' ] },
- { 'a"""b' => [ 'a"b' ] },
- { 'a""""b' => [ 'a"b' ] },
- { 'a"""""b' => [ 'a"b' ] },
- { 'a""""""b' => [ 'a""b' ] },
- { '"a"b"' => [ 'ab' ] },
- { '"a""b"' => [ 'a"b' ] },
- { '"a"""b"' => [ 'a"b' ] },
- { '"a""""b"' => [ 'a"b' ] },
- { '"a"""""b"' => [ 'a""b' ] },
- { '"a""""""b"' => [ 'a""b' ] },
- { '' => [ ] },
- { ' ' => [ ] },
- { '""' => [ '' ] },
- { '" "' => [ ' ' ] },
- { '""a' => [ 'a' ] },
- { '""a b' => [ 'a', 'b' ] },
- { 'a""' => [ 'a' ] },
- { 'a"" b' => [ 'a', 'b' ] },
- { '"" a' => [ '', 'a' ] },
- { 'a ""' => [ 'a', '' ] },
- { 'a "" b' => [ 'a', '', 'b' ] },
- { 'a " " b' => [ 'a', ' ', 'b' ] },
- { 'a " b " c' => [ 'a', ' b ', 'c' ] },
-);
-
-plan tests => 9 + 4*@unix_splits + 4*@win_splits;
-
-blib_load('Module::Build');
-blib_load('Module::Build::Platform::Unix');
-blib_load('Module::Build::Platform::Windows');
-
-#########################
-
-# Should always return an array unscathed
-foreach my $platform ('', '::Platform::Unix', '::Platform::Windows') {
- my $pkg = "Module::Build$platform";
- my @result = $pkg->split_like_shell(['foo', 'bar', 'baz']);
- is @result, 3, "Split using $pkg";
- is "@result", "foo bar baz", "Split using $pkg";
-}
-
-# I think 3.24 isn't actually the majik version, my 3.23 seems to pass...
-my $low_TPW_version = Text::ParseWords->VERSION < 3.24;
-foreach my $test (@unix_splits) {
- # Text::ParseWords bug:
- local $TODO = $low_TPW_version && ((keys %$test)[0] =~ m{\\\n});
-
- do_split_tests('Module::Build::Platform::Unix', $test);
-}
-
-foreach my $test (@win_splits) {
- do_split_tests('Module::Build::Platform::Windows', $test);
-}
-
-
-{
- # Make sure read_args() functions properly as a class method
- my @args = qw(foo=bar --food bard --foods=bards);
- my ($args) = Module::Build->read_args(@args);
- is_deeply($args, {foo => 'bar', food => 'bard', foods => 'bards', ARGV => []});
-}
-
-{
- # Make sure data can make a round-trip through unparse_args() and read_args()
- my %args = (foo => 'bar', food => 'bard', config => {a => 1, b => 2}, ARGV => []);
- my ($args) = Module::Build->read_args( Module::Build->unparse_args(\%args) );
- is_deeply($args, \%args);
-}
-
-{
- # Make sure data can make a round-trip through an external perl
- # process, which can involve the shell command line
-
- # silence the printing for easier matching
- local *Module::Build::log_info = sub {};
-
- my @data = map values(%$_), @unix_splits, @win_splits;
- for my $d (@data) {
- my $out = stdout_of
- ( sub {
- Module::Build->run_perl_script('-le', [], ['print join " ", map "{$_}", @ARGV', @$d]);
- } );
- chomp $out;
- is($out, join(' ', map "{$_}", @$d), "perl round trip for ".join('',map "{$_}", @$d));
- }
-}
-
-{
- # Make sure data can make a round-trip through an external backtick
- # process, which can involve the shell command line
-
- # silence the printing for easier matching
- local *Module::Build::log_info = sub {};
-
- my @data = map values(%$_), @unix_splits, @win_splits;
- for my $d (@data) {
- chomp(my $out = Module::Build->_backticks($^X, '-le', 'print join " ", map "{$_}", @ARGV', @$d));
- is($out, join(' ', map "{$_}", @$d), "backticks round trip for ".join('',map "{$_}", @$d));
- }
-}
-
-{
- # Make sure run_perl_script() propagates @INC
- my $dir = MBTest->tmpdir;
- if ($^O eq 'VMS') {
- # VMS can store INC paths in Unix format with out the trailing
- # directory delimiter.
- $dir = VMS::Filespec::unixify($dir);
- $dir =~ s#/$##;
- }
- local @INC = ($dir, @INC);
- my $output = stdout_of( sub { Module::Build->run_perl_script('-le', [], ['print for @INC']) } );
- like $output, qr{^\Q$dir\E}m;
-}
-
-##################################################################
-sub do_split_tests {
- my ($package, $test) = @_;
-
- my ($string, $expected) = %$test;
- my @result = $package->split_like_shell($string);
- is( 0 + grep( !defined(), @result ), # all defined
- 0,
- "'$string' result all defined" );
- is_deeply(\@result, $expected) or
- diag("$package split_like_shell error \n" .
- ">$string< is not splitting as >" . join("|", @$expected) . '<');
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 63;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-$dist->chdir_in;
-
-#########################
-
-# Here we make sure actions are only called once per dispatch()
-$::x = 0;
-my $mb = Module::Build->subclass
- (
- code => "sub ACTION_loop { die 'recursed' if \$::x++; shift->depends_on('loop'); }"
- )->new( module_name => $dist->name );
-ok $mb;
-
-$mb->dispatch('loop');
-ok $::x;
-
-$mb->dispatch('realclean');
-
-# Make sure the subclass can be subclassed
-my $build2class = ref($mb)->subclass
- (
- code => "sub ACTION_loop2 {}",
- class => 'MBB',
- );
-can_ok( $build2class, 'ACTION_loop' );
-can_ok( $build2class, 'ACTION_loop2' );
-
-
-{ # Make sure globbing works in filenames
- $dist->add_file( 'script', <<'---' );
-#!perl -w
-print "Hello, World!\n";
----
- $dist->regen;
-
- $mb->test_files('*t*');
- my $files = $mb->test_files;
- ok grep {$_ eq 'script'} @$files;
- my $t_basic_t = File::Spec->catfile('t', 'basic.t');
- $t_basic_t = VMS::Filespec::vmsify($t_basic_t) if $^O eq 'VMS';
- ok grep {$_ eq $t_basic_t} @$files;
- ok !grep {$_ eq 'Build.PL' } @$files;
-
- # Make sure order is preserved
- $mb->test_files('foo', 'bar');
- $files = $mb->test_files;
- is @$files, 2;
- is $files->[0], 'foo';
- is $files->[1], 'bar';
-
- $dist->remove_file( 'script' );
- $dist->regen( clean => 1 );
-}
-
-
-{
- # Make sure we can add new kinds of stuff to the build sequence
-
- $dist->add_file( 'test.foo', "content\n" );
- $dist->regen;
-
- my $mb = Module::Build->new( module_name => $dist->name,
- foo_files => {'test.foo', 'lib/test.foo'} );
- ok $mb;
-
- $mb->add_build_element('foo');
- $mb->add_build_element('foo');
- is_deeply $mb->build_elements, [qw(PL support pm xs share_dir pod script foo)],
- 'The foo element should be in build_elements only once';
-
- $mb->dispatch('build');
- ok -e File::Spec->catfile($mb->blib, 'lib', 'test.foo');
-
- $mb->dispatch('realclean');
-
- # revert distribution to a pristine state
- $dist->remove_file( 'test.foo' );
- $dist->regen( clean => 1 );
-}
-
-
-{
- package MBSub;
- use Test::More;
- use vars qw($VERSION @ISA);
- @ISA = qw(Module::Build);
- $VERSION = 0.01;
-
- # Add a new property.
- ok(__PACKAGE__->add_property('foo'));
- # Add a new property with a default value.
- ok(__PACKAGE__->add_property('bar', 'hey'));
- # Add a hash property.
- ok(__PACKAGE__->add_property('hash', {}));
-
-
- # Catch an exception adding an existing property.
- eval { __PACKAGE__->add_property('module_name')};
- like "$@", qr/already exists/;
-}
-
-{
- package MBSub2;
- use Test::More;
- use vars qw($VERSION @ISA);
- @ISA = qw(Module::Build);
- $VERSION = 0.01;
-
- # Add a new property with a different default value than MBSub has.
- ok(__PACKAGE__->add_property('bar', 'yow'));
-}
-
-
-{
- ok my $mb = MBSub->new( module_name => $dist->name );
- isa_ok $mb, 'Module::Build';
- isa_ok $mb, 'MBSub';
- ok $mb->valid_property('foo');
- can_ok $mb, 'module_name';
-
- # Check foo property.
- can_ok $mb, 'foo';
- ok ! $mb->foo;
- ok $mb->foo(1);
- ok $mb->foo;
-
- # Check bar property.
- can_ok $mb, 'bar';
- is $mb->bar, 'hey';
- ok $mb->bar('you');
- is $mb->bar, 'you';
-
- # Check hash property.
- ok $mb = MBSub->new(
- module_name => $dist->name,
- hash => { foo => 'bar', bin => 'foo'}
- );
-
- can_ok $mb, 'hash';
- isa_ok $mb->hash, 'HASH';
- is $mb->hash->{foo}, 'bar';
- is $mb->hash->{bin}, 'foo';
-
- # Check hash property passed via the command-line.
- {
- local @ARGV = (
- '--hash', 'foo=bar',
- '--hash', 'bin=foo',
- );
- ok $mb = MBSub->new( module_name => $dist->name );
- }
-
- can_ok $mb, 'hash';
- isa_ok $mb->hash, 'HASH';
- is $mb->hash->{foo}, 'bar';
- is $mb->hash->{bin}, 'foo';
-
- # Make sure that a different subclass with the same named property has a
- # different default.
- ok $mb = MBSub2->new( module_name => $dist->name );
- isa_ok $mb, 'Module::Build';
- isa_ok $mb, 'MBSub2';
- ok $mb->valid_property('bar');
- can_ok $mb, 'bar';
- is $mb->bar, 'yow';
-}
-
-{
- # Test the meta_add and meta_merge stuff
- ok my $mb = Module::Build->new(
- module_name => $dist->name,
- license => 'perl',
- meta_add => {abstract => 'bar'},
- conflicts => {'Foo::Barxx' => 0},
- );
- my $data = $mb->get_metadata;
- is_deeply $data->{abstract}, 'bar';
-
- $mb->meta_merge(abstract => 'baz');
- $data = $mb->get_metadata;
- is_deeply $data->{abstract}, 'baz';
-
- $mb->meta_merge(
- 'meta-spec' => { version => 2 },
- prereqs => {
- test => {
- requirements => {
- 'Foo::Fooxx' => 0,
- }
- }
- }
- );
- $data = $mb->get_metadata;
- is_deeply $data->{prereqs}{test}{requirements}, { 'Foo::Fooxx' => 0 };
-
-}
-
-{
- # Test interactive prompting
-
- my $ans;
- local $ENV{PERL_MM_USE_DEFAULT};
-
- local $^W = 0;
- local *{Module::Build::_readline} = sub { 'y' };
-
- ok my $mb = Module::Build->new(
- module_name => $dist->name,
- license => 'perl',
- );
-
- eval{ $mb->prompt() };
- like $@, qr/called without a prompt/, 'prompt() requires a prompt';
-
- eval{ $mb->y_n() };
- like $@, qr/called without a prompt/, 'y_n() requires a prompt';
-
- eval{ $mb->y_n('Prompt?', 'invalid default') };
- like $@, qr/Invalid default/, "y_n() requires a default of 'y' or 'n'";
-
-
- $ENV{PERL_MM_USE_DEFAULT} = 1;
-
- eval{ $mb->y_n('Is this a question?') };
- print "\n"; # fake <enter> because the prompt prints before the checks
- like $@, qr/ERROR:/,
- 'Do not allow default-less y_n() for unattended builds';
-
- eval{ $ans = $mb->prompt('Is this a question?') };
- print "\n"; # fake <enter> because the prompt prints before the checks
- like $@, qr/ERROR:/,
- 'Do not allow default-less prompt() for unattended builds';
-
-
- # When running Test::Smoke under a cron job, STDIN will be closed which
- # will fool our _is_interactive() method causing various failures.
- {
- local *{Module::Build::_is_interactive} = sub { 1 };
-
- $ENV{PERL_MM_USE_DEFAULT} = 0;
-
- $ans = $mb->prompt('Is this a question?');
- print "\n"; # fake <enter> after input
- is $ans, 'y', "prompt() doesn't require default for interactive builds";
-
- $ans = $mb->y_n('Say yes');
- print "\n"; # fake <enter> after input
- ok $ans, "y_n() doesn't require default for interactive build";
-
-
- # Test Defaults
- *{Module::Build::_readline} = sub { '' };
-
- $ans = $mb->prompt("Is this a question");
- is $ans, '', "default for prompt() without a default is ''";
-
- $ans = $mb->prompt("Is this a question", 'y');
- is $ans, 'y', " prompt() with a default";
-
- $ans = $mb->y_n("Is this a question", 'y');
- ok $ans, " y_n() with a default";
-
- my @ans = $mb->prompt("Is this a question", undef);
- is_deeply([@ans], [undef], " prompt() with undef() default");
- }
-
-}
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 4;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-$dist->chdir_in;
-
-my $mb = Module::Build->new_from_context;
-
-{
- # Make sure copy_if_modified() can handle spaces in filenames
-
- my @tmp;
- push @tmp, MBTest->tmpdir for (0 .. 1);
-
- my $filename = 'file with spaces.txt';
-
- my $file = File::Spec->catfile($tmp[0], $filename);
- open(my $fh, '>', $file) or die "Can't create $file: $!";
- print $fh "Foo\n";
- close $fh;
- ok -e $file;
-
-
- my $file2 = $mb->copy_if_modified(from => $file, to_dir => $tmp[1]);
- ok $file2;
- ok -e $file2;
-}
-
-{
- # Try some dir_contains() combinations
- my $first = File::Spec->catdir('', 'one', 'two');
- my $second = File::Spec->catdir('', 'one', 'two', 'three');
-
- ok( Module::Build->dir_contains($first, $second) );
-}
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 23;
-
-blib_load('Module::Build');
-
-use DistGen;
-
-my $dist = DistGen->new;
-$dist->regen;
-$dist->chdir_in;
-
-my $restart = sub {
- # we're redefining the same package as we go, so...
- delete($::{'MyModuleBuilder::'});
- delete($INC{'MyModuleBuilder.pm'});
- $dist->regen( clean => 1 );
-};
-
-########################################################################
-{ # check the =item style
-my $mb = Module::Build->subclass(
- code => join "\n", map {s/^ {4}//; $_} split /\n/, <<' ---',
- =head1 ACTIONS
-
- =over
-
- =item foo
-
- Does the foo thing.
-
- =item bar
-
- Does the bar thing.
-
- =item help
-
- Does the help thing.
-
- You should probably not be seeing this. That is, we haven't
- overridden the help action, but we're able to override just the
- docs? That almost seems reasonable, but is probably wrong.
-
- =back
-
- =cut
-
- sub ACTION_foo { die "fooey" }
- sub ACTION_bar { die "barey" }
- sub ACTION_baz { die "bazey" }
-
- # guess we can have extra pod later
-
- =over
-
- =item baz
-
- Does the baz thing.
-
- =back
-
- =cut
-
- ---
- )->new(
- module_name => $dist->name,
- );
-
-ok $mb;
-can_ok($mb, 'ACTION_foo');
-
-foreach my $action (qw(foo bar baz)) { # typical usage
- my $doc = $mb->get_action_docs($action);
- ok($doc, "got doc for '$action'");
- like($doc, qr/^=\w+ $action\n\nDoes the $action thing\./s,
- 'got the right doc');
-}
-
-{ # user typo'd the action name
- ok( ! eval {$mb->get_action_docs('batz'); 1}, 'slap');
- like($@, qr/No known action 'batz'/, 'informative error');
-}
-
-{ # XXX this one needs some thought
- my $action = 'help';
- my $doc = $mb->get_action_docs($action);
- ok($doc, "got doc for '$action'");
- 0 and warn "help doc >\n$doc<\n";
- TODO: {
- local $TODO = 'Do we allow overrides on just docs?';
- unlike($doc, qr/^=\w+ $action\n\nDoes the $action thing\./s,
- 'got the right doc');
- }
-}
-} # end =item style
-$restart->();
-########################################################################
-if(0) { # the =item style without spanning =head1 sections
-my $mb = Module::Build->subclass(
- code => join "\n", map {s/^ {4}//; $_} split /\n/, <<' ---',
- =head1 ACTIONS
-
- =over
-
- =item foo
-
- Does the foo thing.
-
- =item bar
-
- Does the bar thing.
-
- =back
-
- =head1 thbbt
-
- =over
-
- =item baz
-
- Should not see this.
-
- =back
-
- =cut
-
- sub ACTION_foo { die "fooey" }
- sub ACTION_bar { die "barey" }
- sub ACTION_baz { die "bazey" }
-
- ---
- )->new(
- module_name => $dist->name,
- );
-
-ok $mb;
-can_ok($mb, 'ACTION_foo');
-
-foreach my $action (qw(foo bar)) { # typical usage
- my $doc = $mb->get_action_docs($action);
- ok($doc, "got doc for '$action'");
- like($doc, qr/^=\w+ $action\n\nDoes the $action thing\./s,
- 'got the right doc');
-}
-is($mb->get_action_docs('baz'), undef, 'no jumping =head1 sections');
-
-} # end =item style without spanning =head1's
-$restart->();
-########################################################################
-TODO: { # the =item style with 'Actions' not 'ACTIONS'
-local $TODO = 'Support capitalized Actions section';
-my $mb = Module::Build->subclass(
- code => join "\n", map {s/^ {4}//; $_} split /\n/, <<' ---',
- =head1 Actions
-
- =over
-
- =item foo
-
- Does the foo thing.
-
- =item bar
-
- Does the bar thing.
-
- =back
-
- =cut
-
- sub ACTION_foo { die "fooey" }
- sub ACTION_bar { die "barey" }
-
- ---
- )->new(
- module_name => $dist->name,
- );
-
-foreach my $action (qw(foo bar)) { # typical usage
- my $doc = $mb->get_action_docs($action);
- ok($doc, "got doc for '$action'");
- like($doc || 'undef', qr/^=\w+ $action\n\nDoes the $action thing\./s,
- 'got the right doc');
-}
-
-} # end =item style with Actions
-$restart->();
-########################################################################
-{ # check the =head2 style
-my $mb = Module::Build->subclass(
- code => join "\n", map {s/^ {4}//; $_} split /\n/, <<' ---',
- =head1 ACTIONS
-
- =head2 foo
-
- Does the foo thing.
-
- =head2 bar
-
- Does the bar thing.
-
- =head3 bears
-
- Be careful with bears.
-
- =cut
-
- sub ACTION_foo { die "fooey" }
- sub ACTION_bar { die "barey" }
- sub ACTION_baz { die "bazey" }
- sub ACTION_batz { die "batzey" }
-
- # guess we can have extra pod later
- # Though, I do wonder whether we should allow them to mix...
- # maybe everything should have to be head2?
-
- =head2 baz
-
- Does the baz thing.
-
- =head4 What's a baz?
-
- =head1 not this part
-
- This is level 1, so the stuff about baz is done.
-
- =head1 Thing
-
- =head2 batz
-
- This is not an action doc.
-
- =cut
-
- ---
- )->new(
- module_name => $dist->name,
- );
-
-my %also = (
- foo => '',
- bar => "\n=head3 bears\n\nBe careful with bears.\n",
- baz => "\n=head4 What's a baz\\?\n",
-);
-
-foreach my $action (qw(foo bar baz)) {
- my $doc = $mb->get_action_docs($action);
- ok($doc, "got doc for '$action'");
- my $and = $also{$action};
- like($doc || 'undef',
- qr/^=\w+ $action\n\nDoes the $action thing\.\n$and\n$/s,
- 'got the right doc');
-}
-is($mb->get_action_docs('batz'), undef, 'nothing after uplevel');
-
-} # end =head2 style
-########################################################################
-
-# cleanup
-$dist->clean();
-
-# vim:ts=2:sw=2:et:sta
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 34;
-
-blib_load('Module::Build');
-
-use Config;
-use Cwd ();
-my $cwd = Cwd::cwd;
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-$dist->chdir_in;
-
-#########################
-
-
-$dist->add_file( 'script', <<'---' );
-#!perl -w
-print "Hello, World!\n";
----
-$dist->change_build_pl
-({
- module_name => $dist->name,
- scripts => [ 'script' ],
- license => 'perl',
- requires => { 'File::Spec' => 0 },
-});
-$dist->regen;
-
-
-use File::Spec::Functions qw( catdir );
-
-my $mb = Module::Build->new_from_context(
- # Need default install paths to ensure manpages get generated.
- installdirs => 'site',
- config => {
- installman1dir => catdir($tmp, 'man', 'man1'),
- installman3dir => catdir($tmp, 'man', 'man3'),
- installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'),
- installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'),
- ## We also used to have HTML paths here, but building HTML docs
- ## can be super slow, and we never checked the result anyway.
- }
-
-);
-
-ok $mb;
-
-
-my $destdir = File::Spec->catdir($cwd, 't', 'install_test' . $$);
-$mb->add_to_cleanup($destdir);
-
-{
- eval {$mb->dispatch('install', destdir => $destdir)};
- is $@, '';
-
- my @libdir = strip_volume( $mb->install_destination('lib') );
- my $install_to = File::Spec->catfile($destdir, @libdir, $dist->name ) . '.pm';
- file_exists($install_to);
-
- local @INC = (@INC, File::Spec->catdir($destdir, @libdir));
- eval "require @{[$dist->name]}";
- is $@, '';
-
- # Make sure there's a packlist installed
- my $archdir = $mb->install_destination('arch');
- my @dirs = strip_volume($archdir);
- my $packlist = File::Spec->catfile
- ($destdir, @dirs, 'auto', $dist->name, '.packlist');
- is -e $packlist, 1, "$packlist should be written";
-}
-
-{
- eval {$mb->dispatch('install', installdirs => 'core', destdir => $destdir)};
- is $@, '';
- my @libdir = strip_volume( $Config{installprivlib} );
- my $install_to = File::Spec->catfile($destdir, @libdir, $dist->name ) . '.pm';
- file_exists($install_to);
-}
-
-{
- my $libdir = File::Spec->catdir(File::Spec->rootdir, 'foo', 'bar');
- eval {$mb->dispatch('install', install_path => {lib => $libdir}, destdir => $destdir)};
- is $@, '';
- my @dirs = strip_volume($libdir);
- my $install_to = File::Spec->catfile($destdir, @dirs, $dist->name ) . '.pm';
- file_exists($install_to);
-}
-
-{
- my $libdir = File::Spec->catdir(File::Spec->rootdir, 'foo', 'base');
- eval {$mb->dispatch('install', install_base => $libdir, destdir => $destdir)};
- is $@, '';
- my @dirs = strip_volume($libdir);
- my $install_to = File::Spec->catfile($destdir, @dirs, 'lib', 'perl5', $dist->name ) . '.pm';
- file_exists($install_to);
-}
-
-{
- # Test the ConfigData stuff
-
- $mb->config_data(foo => 'bar');
- $mb->features(baz => 1);
- $mb->auto_features(auto_foo => {requires => {'File::Spec' => 0}});
- eval {$mb->dispatch('install', destdir => $destdir)};
- is $@, '';
-
- my @libdir = strip_volume( $mb->install_destination('lib') );
- local @INC = (@INC, File::Spec->catdir($destdir, @libdir));
- eval "require @{[$dist->name]}::ConfigData";
-
- is $mb->feature('auto_foo'), 1;
-
- SKIP: {
- skip $@, 5 if @_;
-
- # Make sure the values are present
- my $config = $dist->name . '::ConfigData';
- is( $config->config('foo'), 'bar' );
- ok( $config->feature('baz') );
- ok( $config->feature('auto_foo') );
- ok( not $config->feature('nonexistent') );
-
- # Add a new value to the config set
- $config->set_config(floo => 'bhlar');
- is( $config->config('floo'), 'bhlar' );
-
- # Make sure it actually got written
- $config->write;
- delete $INC{"@{[$dist->name]}/ConfigData.pm"};
- {
- local $^W; # Avoid warnings for subroutine redefinitions
- eval "require $config";
- }
- is( $config->config('floo'), 'bhlar' );
- }
-}
-
-
-eval {$mb->dispatch('realclean')};
-is $@, '';
-
-{
- # Try again by running the script rather than with programmatic interface
- my $libdir = File::Spec->catdir('', 'foo', 'lib');
- eval {$mb->run_perl_script('Build.PL', [], ['--install_path', "lib=$libdir"])};
- is $@, '';
-
- my $cmd = 'Build';
- $cmd .= ".COM" if $^O eq 'VMS';
- eval {$mb->run_perl_script($cmd, [], ['install', '--destdir', $destdir])};
- is $@, '';
- my $install_to = File::Spec->catfile($destdir, $libdir, $dist->name ) . '.pm';
- file_exists($install_to);
-
- my $basedir = File::Spec->catdir('', 'bar');
- eval {$mb->run_perl_script($cmd, [], ['install', '--destdir', $destdir,
- '--install_base', $basedir])};
- is $@, '';
-
- $install_to = File::Spec->catfile($destdir, $libdir, $dist->name ) . '.pm';
- is -e $install_to, 1, "Look for file at $install_to";
-
- eval {$mb->dispatch('realclean')};
- is $@, '';
-}
-
-{
- # Make sure 'install_path' overrides 'install_base'
- my $mb = Module::Build->new( module_name => $dist->name,
- install_base => File::Spec->catdir('', 'foo'),
- install_path => {
- lib => File::Spec->catdir('', 'bar')
- }
- );
- ok $mb;
- is $mb->install_destination('lib'), File::Spec->catdir('', 'bar');
-}
-
-{
- $dist->add_file( 'lib/Simple/Docs.pod', <<'---' );
-=head1 NAME
-
-Simple::Docs - Simple pod
-
-=head1 AUTHOR
-
-Simple Man <simple@example.com>
-
-=cut
----
- $dist->regen;
-
- # _find_file_by_type() isn't a public method, but this is currently
- # the only easy way to test that it works properly.
- my $pods = $mb->_find_file_by_type('pod', 'lib');
- is keys %$pods, 1;
- my $expect = $mb->localize_file_path('lib/Simple/Docs.pod');
-
- is $pods->{$expect}, $expect;
-
- my $pms = $mb->_find_file_by_type('awefawef', 'lib');
- ok $pms;
- is keys %$pms, 0;
-
- $pms = $mb->_find_file_by_type('pod', 'awefawef');
- ok $pms;
- is keys %$pms, 0;
-
- # revert to pristine state
- $dist->regen( clean => 1 );
-}
-
-sub strip_volume {
- my $dir = shift;
- (undef, $dir) = File::Spec->splitpath( $dir, 1 );
- my @dirs = File::Spec->splitdir($dir);
- return @dirs;
-}
-
-sub file_exists {
- my $file = shift;
- ok -e $file or diag("Expected $file to exist, but it doesn't");
-}
-
+++ /dev/null
-#!perl -w
-# Contributed by: Thorben Jaendling
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 6;
-
-blib_load('Module::Build');
-
-use File::Spec::Functions qw( catdir catfile );
-
-my $tmp = MBTest->tmpdir;
-my $output;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-
-# note("Dist is in $tmp\n");
-
-$dist->add_file("Build.PL", <<'===EOF===');
-#!perl -w
-
-use strict;
-use Module::Build;
-
-my $subclass = Module::Build->subclass(code => <<'=EOF=');
-sub copy_files
-{
- my $self = shift;
- my $dir = shift;
-
- my $files = $self->rscan_dir($dir, sub {-f $_ and not m!/\.|[#~]$!});
-
- foreach my $file (@$files) {
- $self->copy_if_modified(from => $file, to_dir => "blib");
- }
-}
-
-#Copy etc files to blib
-sub process_etc_files
-{
- my $self = shift;
-
- $self->copy_files("etc");
-}
-
-#Copy share files to blib
-sub process_shared_files
-{
- my $self = shift;
-
- $self->copy_files("shared");
-}
-
-1;
-=EOF=
-
-my $build = $subclass->new(
- module_name => 'Simple',
- license => 'perl'
-);
-
-$build->add_build_element('etc');
-$build->add_build_element('shared');
-
-my $distdir = lc $build->dist_name();
-
-foreach my $id ('core', 'site', 'vendor') {
- #Where to install these build types when using prefix symantics
- $build->prefix_relpaths($id, 'shared' => "shared/$distdir");
- $build->prefix_relpaths($id, 'etc' => "etc/$distdir");
-
- #Where to install these build types when using default symantics
- my $set = $build->install_sets($id);
- $set->{'shared'} = '/usr/'.($id eq 'site' ? 'local/':'')."shared/$distdir";
- $set->{'etc'} = ($id eq 'site' ? '/usr/local/etc/':'/etc/').$distdir;
-}
-
-#Where to install these types when using install_base symantics
-$build->install_base_relpaths('shared' => "shared/$distdir");
-$build->install_base_relpaths('etc' => "etc/$distdir");
-
-$build->create_build_script();
-
-===EOF===
-
-#Test Build.PL exists ok?
-
-$dist->add_file("etc/config", <<'===EOF===');
-[main]
-Foo = bar
-Jim = bob
-
-[supplemental]
-stardate = 1234344
-
-===EOF===
-
-$dist->add_file("shared/data", <<'===EOF===');
-7 * 9 = 42?
-
-===EOF===
-
-$dist->add_file("shared/html/index.html", <<'===EOF===');
-<HTML>
- <BODY>
- <H1>Hello World!</H1>
- </BODY>
-</HTML>
-
-===EOF===
-
-$dist->regen;
-$dist->chdir_in;
-
-my $installdest = catdir($tmp, 't', "install_extra_targets-$$");
-
-$output = stdout_of sub { $dist->run_build_pl("--install_base=$installdest") };
-
-$output .= stdout_of sub { $dist->run_build };
-
-my $error;
-$error++ unless ok(-e "blib/etc/config", "Built etc/config");
-$error++ unless ok(-e "blib/shared/data", "Built shared/data");
-$error++ unless ok(-e "blib/shared/html/index.html", "Built shared/html");
-diag "OUTPUT:\n$output" if $error;
-
-$output = stdout_of sub { $dist->run_build('install') };
-
-$error = 0;
-$error++ unless ok(-e catfile($installdest, qw/etc simple config/), "installed etc/config");
-$error++ unless ok(-e catfile($installdest, qw/shared simple data/), "installed shared/data");
-$error++ unless ok(-e catfile($installdest, qw/shared simple html index.html/), "installed shared/html");
-diag "OUTPUT:\n$output" if $error;
-
+++ /dev/null
-package DistGen;
-
-use strict;
-
-use vars qw( $VERSION $VERBOSE @EXPORT_OK);
-
-$VERSION = '0.01';
-$VERBOSE = 0;
-
-use Carp;
-
-use MBTest ();
-use Cwd ();
-use File::Basename ();
-use File::Find ();
-use File::Path ();
-use File::Spec ();
-use Tie::CPHash;
-use Data::Dumper;
-
-my $vms_mode;
-my $vms_lower_case;
-
-BEGIN {
- $vms_mode = 0;
- $vms_lower_case = 0;
- if( $^O eq 'VMS' ) {
- # For things like vmsify()
- require VMS::Filespec;
- VMS::Filespec->import;
- $vms_mode = 1;
- $vms_lower_case = 1;
- my $vms_efs_case = 0;
- my $unix_rpt = 0;
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
- $unix_rpt = VMS::Feature::current("filename_unix_report");
- $vms_efs_case = VMS::Feature::current("efs_case_preserve");
- } else {
- my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
- my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
- $vms_efs_case = $efs_case =~ /^[ET1]/i;
- }
- $vms_mode = 0 if $unix_rpt;
- $vms_lower_case = 0 if $vms_efs_case;
- }
-}
-BEGIN {
- require Exporter;
- *{import} = \&Exporter::import;
- @EXPORT_OK = qw(
- undent
- );
-}
-
-sub undent {
- my ($string) = @_;
-
- my ($space) = $string =~ m/^(\s+)/;
- $string =~ s/^$space//gm;
-
- return($string);
-}
-
-sub chdir_all ($) {
- # OS/2 has "current directory per disk", undeletable;
- # doing chdir() to another disk won't change cur-dir of initial disk...
- chdir('/') if $^O eq 'os2';
- chdir shift;
-}
-
-########################################################################
-
-END { chdir_all(MBTest->original_cwd); }
-
-sub new {
- my $self = bless {}, shift;
- $self->reset(@_);
-}
-
-sub reset {
- my $self = shift;
- my %options = @_;
-
- $options{name} ||= 'Simple';
- $options{version} ||= q{'0.01'};
- $options{license} ||= 'perl';
- $options{dir} = File::Spec->rel2abs(
- defined $options{dir} ? $options{dir} : MBTest->tmpdir
- );
-
- my %data = (
- no_manifest => 0,
- xs => 0,
- inc => 0,
- %options,
- );
- %$self = %data;
-
- tie %{$self->{filedata}}, 'Tie::CPHash';
-
- tie %{$self->{pending}{change}}, 'Tie::CPHash';
-
- # start with a fresh, empty directory
- if ( -d $self->dirname ) {
- warn "Warning: Removing existing directory '@{[$self->dirname]}'\n";
- File::Path::rmtree( $self->dirname );
- }
- File::Path::mkpath( $self->dirname );
-
- $self->_gen_default_filedata();
-
- return $self;
-}
-
-sub remove {
- my $self = shift;
- $self->chdir_original if($self->did_chdir);
- File::Path::rmtree( $self->dirname );
- return $self;
-}
-
-sub revert {
- my ($self, $file) = @_;
- if ( defined $file ) {
- delete $self->{filedata}{$file};
- delete $self->{pending}{$_}{$file} for qw/change remove/;
- }
- else {
- delete $self->{filedata}{$_} for keys %{ $self->{filedata} };
- for my $pend ( qw/change remove/ ) {
- delete $self->{pending}{$pend}{$_} for keys %{ $self->{pending}{$pend} };
- }
- }
- $self->_gen_default_filedata;
-}
-
-sub _gen_default_filedata {
- my $self = shift;
-
- # TODO maybe a public method like this (but with a better name?)
- my $add_unless = sub {
- my $self = shift;
- my ($member, $data) = @_;
- $self->add_file($member, $data) unless($self->{filedata}{$member});
- };
-
- if ( ! $self->{inc} ) {
- $self->$add_unless('Build.PL', undent(<<" ---"));
- use strict;
- use Module::Build;
-
- my \$builder = Module::Build->new(
- module_name => '$self->{name}',
- license => '$self->{license}',
- );
-
- \$builder->create_build_script();
- ---
- }
- else {
- $self->$add_unless('Build.PL', undent(<<" ---"));
- use strict;
- use inc::latest 'Module::Build';
-
- my \$builder = Module::Build->new(
- module_name => '$self->{name}',
- license => '$self->{license}',
- );
-
- \$builder->create_build_script();
- ---
- }
-
- my $module_filename =
- join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm';
-
- unless ( $self->{xs} ) {
- $self->$add_unless($module_filename, undent(<<" ---"));
- package $self->{name};
-
- use vars qw( \$VERSION );
- \$VERSION = $self->{version};
-
- use strict;
-
- 1;
-
- __END__
-
- =head1 NAME
-
- $self->{name} - Perl extension for blah blah blah
-
- =head1 DESCRIPTION
-
- Stub documentation for $self->{name}.
-
- =head1 AUTHOR
-
- A. U. Thor, a.u.thor\@a.galaxy.far.far.away
-
- =cut
- ---
-
- $self->$add_unless('t/basic.t', undent(<<" ---"));
- use Test::More tests => 1;
- use strict;
-
- use $self->{name};
- ok 1;
- ---
-
- } else {
- $self->$add_unless($module_filename, undent(<<" ---"));
- package $self->{name};
-
- \$VERSION = $self->{version};
-
- require Exporter;
- require DynaLoader;
-
- \@ISA = qw(Exporter DynaLoader);
- \@EXPORT_OK = qw( okay );
-
- bootstrap $self->{name} \$VERSION;
-
- 1;
-
- __END__
-
- =head1 NAME
-
- $self->{name} - Perl extension for blah blah blah
-
- =head1 DESCRIPTION
-
- Stub documentation for $self->{name}.
-
- =head1 AUTHOR
-
- A. U. Thor, a.u.thor\@a.galaxy.far.far.away
-
- =cut
- ---
-
- my $xs_filename =
- join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs';
- $self->$add_unless($xs_filename, undent(<<" ---"));
- #include "EXTERN.h"
- #include "perl.h"
- #include "XSUB.h"
-
- MODULE = $self->{name} PACKAGE = $self->{name}
-
- SV *
- okay()
- CODE:
- RETVAL = newSVpv( "ok", 0 );
- OUTPUT:
- RETVAL
-
- const char *
- xs_version()
- CODE:
- RETVAL = XS_VERSION;
- OUTPUT:
- RETVAL
-
- const char *
- version()
- CODE:
- RETVAL = VERSION;
- OUTPUT:
- RETVAL
- ---
-
- # 5.6 is missing const char * in its typemap
- $self->$add_unless('typemap', undent(<<" ---"));
- const char *\tT_PV
- ---
-
- $self->$add_unless('t/basic.t', undent(<<" ---"));
- use Test::More tests => 2;
- use strict;
-
- use $self->{name};
- ok 1;
-
- ok( $self->{name}::okay() eq 'ok' );
- ---
- }
-}
-
-sub _gen_manifest {
- my $self = shift;
- my $manifest = shift;
-
- open(my $fh, '>', $manifest ) or do {
- die "Can't write '$manifest'\n";
- };
-
- my @files = ( 'MANIFEST', keys %{$self->{filedata}} );
- my $data = join( "\n", sort @files ) . "\n";
- print $fh $data;
- close( $fh );
-
- $self->{filedata}{MANIFEST} = $data;
- $self->{pending}{change}{MANIFEST} = 1;
-}
-
-sub name { shift()->{name} }
-
-sub dirname {
- my $self = shift;
- my $dist = $self->{distdir} || join( '-', split( /::/, $self->{name} ) );
- return File::Spec->catdir( $self->{dir}, $dist );
-}
-
-sub _real_filename {
- my $self = shift;
- my $filename = shift;
- return File::Spec->catfile( split( /\//, $filename ) );
-}
-
-sub regen {
- my $self = shift;
- my %opts = @_;
-
- my $dist_dirname = $self->dirname;
-
- if ( $opts{clean} ) {
- $self->clean() if -d $dist_dirname;
- } else {
- # TODO: This might leave dangling directories; e.g. if the removed file
- # is 'lib/Simple/Simon.pm', the directory 'lib/Simple' will be left
- # even if there are no files left in it. However, clean() will remove it.
- my @files = keys %{$self->{pending}{remove}};
- foreach my $file ( @files ) {
- my $real_filename = $self->_real_filename( $file );
- my $fullname = File::Spec->catfile( $dist_dirname, $real_filename );
- if ( -e $fullname ) {
- 1 while unlink( $fullname );
- }
- print "Unlinking pending file '$file'\n" if $VERBOSE;
- delete( $self->{pending}{remove}{$file} );
- }
- }
-
- foreach my $file ( keys( %{$self->{filedata}} ) ) {
- my $real_filename = $self->_real_filename( $file );
- my $fullname = File::Spec->catfile( $dist_dirname, $real_filename );
-
- if ( ! -e $fullname ||
- ( -e $fullname && $self->{pending}{change}{$file} ) ) {
-
- print "Changed file '$file'.\n" if $VERBOSE;
-
- my $dirname = File::Basename::dirname( $fullname );
- unless ( -d $dirname ) {
- File::Path::mkpath( $dirname ) or do {
- die "Can't create '$dirname'\n";
- };
- }
-
- if ( -e $fullname ) {
- 1 while unlink( $fullname );
- }
-
- open(my $fh, '>', $fullname) or do {
- die "Can't write '$fullname'\n";
- };
- print $fh $self->{filedata}{$file};
- close( $fh );
- }
-
- delete( $self->{pending}{change}{$file} );
- }
-
- my $manifest = File::Spec->catfile( $dist_dirname, 'MANIFEST' );
- unless ( $self->{no_manifest} ) {
- if ( -e $manifest ) {
- 1 while unlink( $manifest );
- }
- $self->_gen_manifest( $manifest );
- }
- return $self;
-}
-
-sub clean {
- my $self = shift;
-
- my $here = Cwd::abs_path();
- my $there = File::Spec->rel2abs( $self->dirname() );
-
- if ( -d $there ) {
- chdir( $there ) or die "Can't change directory to '$there'\n";
- } else {
- die "Distribution not found in '$there'\n";
- }
-
- my %names;
- tie %names, 'Tie::CPHash';
- foreach my $file ( keys %{$self->{filedata}} ) {
- my $filename = $self->_real_filename( $file );
- $filename = lc($filename) if $vms_lower_case;
- my $dirname = File::Basename::dirname( $filename );
-
- $names{$filename} = 0;
-
- print "Splitting '$dirname'\n" if $VERBOSE;
- my @dirs = File::Spec->splitdir( $dirname );
- while ( @dirs ) {
- my $dir = ( scalar(@dirs) == 1
- ? $dirname
- : File::Spec->catdir( @dirs ) );
- if (length $dir) {
- print "Setting directory name '$dir' in \%names\n" if $VERBOSE;
- $names{$dir} = 0;
- }
- pop( @dirs );
- }
- }
-
- File::Find::finddepth( sub {
- my $name = File::Spec->canonpath( $File::Find::name );
-
- if ($vms_mode) {
- if ($name ne '.') {
- $name =~ s/\.\z//;
- $name = vmspath($name) if -d $name;
- }
- }
- if ($^O eq 'VMS') {
- $name = File::Spec->rel2abs($name) if $name eq File::Spec->curdir();
- }
-
- if ( not exists $names{$name} ) {
- print "Removing '$name'\n" if $VERBOSE;
- File::Path::rmtree( $_ );
- }
- }, ($^O eq 'VMS' ? './' : File::Spec->curdir) );
-
- chdir_all( $here );
- return $self;
-}
-
-sub add_file {
- my $self = shift;
- $self->change_file( @_ );
-}
-
-sub remove_file {
- my $self = shift;
- my $file = shift;
- unless ( exists $self->{filedata}{$file} ) {
- warn "Can't remove '$file': It does not exist.\n" if $VERBOSE;
- }
- delete( $self->{filedata}{$file} );
- $self->{pending}{remove}{$file} = 1;
- return $self;
-}
-
-sub change_build_pl {
- my ($self, @opts) = @_;
-
- my $opts = ref $opts[0] eq 'HASH' ? $opts[0] : { @opts };
-
- local $Data::Dumper::Terse = 1;
- (my $args = Dumper($opts)) =~ s/^\s*\{|\}\s*$//g;
-
- $self->change_file( 'Build.PL', undent(<<" ---") );
- use strict;
- use Module::Build;
- my \$b = Module::Build->new(
- # Some CPANPLUS::Dist::Build versions need to allow mismatches
- # On logic: thanks to Module::Install, CPAN.pm must set both keys, but
- # CPANPLUS sets only the one
- allow_mb_mismatch => (
- \$ENV{PERL5_CPANPLUS_IS_RUNNING} && ! \$ENV{PERL5_CPAN_IS_RUNNING} ? 1 : 0
- ),
- $args
- );
- \$b->create_build_script();
- ---
- return $self;
-}
-
-sub change_file {
- my $self = shift;
- my $file = shift;
- my $data = shift;
- $self->{filedata}{$file} = $data;
- $self->{pending}{change}{$file} = 1;
- return $self;
-}
-
-sub get_file {
- my $self = shift;
- my $file = shift;
- exists($self->{filedata}{$file}) or croak("no such entry: '$file'");
- return $self->{filedata}{$file};
-}
-
-sub chdir_in {
- my $self = shift;
- $self->{original_dir} ||= Cwd::cwd; # only once!
- my $dir = $self->dirname;
- chdir($dir) or die "Can't chdir to '$dir': $!";
- return $self;
-}
-########################################################################
-
-sub did_chdir { exists shift()->{original_dir} }
-
-########################################################################
-
-sub chdir_original {
- my $self = shift;
-
- my $dir = delete $self->{original_dir};
- chdir_all($dir) or die "Can't chdir to '$dir': $!";
- return $self;
-}
-########################################################################
-
-sub new_from_context {
- my ($self, @args) = @_;
- require Module::Build;
- return Module::Build->new_from_context( quiet => 1, @args );
-}
-
-sub run_build_pl {
- my ($self, @args) = @_;
- require Module::Build;
- return Module::Build->run_perl_script('Build.PL', [], [@args])
-}
-
-sub run_build {
- my ($self, @args) = @_;
- require Module::Build;
- my $build_script = $^O eq 'VMS' ? 'Build.com' : 'Build';
- return Module::Build->run_perl_script($build_script, [], [@args])
-}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-DistGen - Creates simple distributions for testing.
-
-=head1 SYNOPSIS
-
- use DistGen;
-
- # create distribution and prepare to test
- my $dist = DistGen->new(name => 'Foo::Bar');
- $dist->chdir_in;
-
- # change distribution files
- $dist->add_file('t/some_test.t', $contents);
- $dist->change_file('MANIFEST.SKIP', $new_contents);
- $dist->remove_file('t/some_test.t');
- $dist->regen;
-
- # undo changes and clean up extraneous files
- $dist->revert;
- $dist->clean;
-
- # exercise the command-line interface
- $dist->run_build_pl();
- $dist->run_build('test');
-
- # start over as a new distribution
- $dist->reset( name => 'Foo::Bar', xs => 1 );
- $dist->chdir_in;
-
-=head1 USAGE
-
-A DistGen object manages a set of files in a distribution directory.
-
-The C<new()> constructor initializes the object and creates an empty
-directory for the distribution. It does not create files or chdir into
-the directory. The C<reset()> method re-initializes the object in a
-new directory with new parameters. It also does not create files or change
-the current directory.
-
-Some methods only define the target state of the distribution. They do B<not>
-make any changes to the filesystem:
-
- add_file
- change_file
- change_build_pl
- remove_file
- revert
-
-Other methods then change the filesystem to match the target state of
-the distribution:
-
- clean
- regen
- remove
-
-Other methods are provided for a convenience during testing. The
-most important is the one to enter the distribution directory:
-
- chdir_in
-
-Additional methods portably encapsulate running Build.PL and Build:
-
- run_build_pl
- run_build
-
-=head1 API
-
-=head2 Constructors
-
-=head3 new()
-
-Create a new object and an empty directory to hold the distribution's files.
-If no C<dir> option is provided, it defaults to MBTest->tmpdir, which sets
-a different temp directory for Perl core testing and CPAN testing.
-
-The C<new> method does not write any files -- see L</regen()> below.
-
- my $dist = DistGen->new(
- name => 'Foo::Bar',
- version => '0.01',
- license => 'perl',
- dir => MBTest->tmpdir,
- xs => 1,
- no_manifest => 0,
- );
-
-The parameters are as follows.
-
-=over
-
-=item name
-
-The name of the module this distribution represents. The default is
-'Simple'. This should be a "Foo::Bar" (module) name, not a "Foo-Bar"
-dist name.
-
-=item version
-
-The version string that will be set. (E.g. C<our $VERSION = 0.01>)
-Note -- to put this value in quotes, add those to the string.
-
- version => q{'0.01_01'}
-
-=item license
-
-The license string that will be set in Build.PL. Defaults to 'perl'.
-
-=item dir
-
-The (parent) directory in which to create the distribution directory. The
-distribution will be created under this according to C<distdir> parameter
-below. Defaults to a temporary directory.
-
- $dist = DistGen->new( dir => '/tmp/MB-test' );
- $dist->regen;
-
- # distribution files have been created in /tmp/MB-test/Simple
-
-=item distdir
-
-The name of the distribution directory to create. Defaults to the dist form of
-C<name>, e.g. 'Foo-Bar' if C<name> is 'Foo::Bar'.
-
-=item xs
-
-If true, generates an XS based module.
-
-=item no_manifest
-
-If true, C<regen()> will not create a MANIFEST file.
-
-=back
-
-The following files are added as part of the default distribution:
-
- Build.PL
- lib/Simple.pm # based on name parameter
- t/basic.t
-
-If an XS module is generated, Simple.pm and basic.t are different and
-the following files are also added:
-
- typemap
- lib/Simple.xs # based on name parameter
-
-=head3 reset()
-
-The C<reset> method re-initializes the object as if it were generated
-from a fresh call to C<new>. It takes the same optional parameters as C<new>.
-
- $dist->reset( name => 'Foo::Bar', xs => 0 );
-
-=head2 Adding and editing files
-
-Note that C<$filename> should always be specified with unix-style paths,
-and are relative to the distribution root directory, e.g. C<lib/Module.pm>.
-
-No changes are made to the filesystem until the distribution is regenerated.
-
-=head3 add_file()
-
-Add a $filename containing $content to the distribution.
-
- $dist->add_file( $filename, $content );
-
-=head3 change_file()
-
-Changes the contents of $filename to $content. No action is performed
-until the distribution is regenerated.
-
- $dist->change_file( $filename, $content );
-
-=head3 change_build_pl()
-
-A wrapper around change_file specifically for setting Build.PL. Instead
-of file C<$content>, it takes a hash-ref of Module::Build constructor
-arguments:
-
- $dist->change_build_pl(
- {
- module_name => $dist->name,
- dist_version => '3.14159265',
- license => 'perl',
- create_readme => 1,
- }
- );
-
-=head3 get_file
-
-Retrieves the target contents of C<$filename>.
-
- $content = $dist->get_file( $filename );
-
-=head3 remove_file()
-
-Removes C<$filename> from the distribution.
-
- $dist->remove_file( $filename );
-
-=head3 revert()
-
-Returns the object to its initial state, or given a $filename it returns that
-file to its initial state if it is one of the built-in files.
-
- $dist->revert;
- $dist->revert($filename);
-
-=head2 Changing the distribution directory
-
-These methods immediately affect the filesystem.
-
-=head3 regen()
-
-Regenerate all missing or changed files. Also deletes any files
-flagged for removal with remove_file().
-
- $dist->regen(clean => 1);
-
-If the optional C<clean> argument is given, it also calls C<clean>. These
-can also be chained like this, instead:
-
- $dist->clean->regen;
-
-=head3 clean()
-
-Removes any files that are not part of the distribution.
-
- $dist->clean;
-
-=head3 remove()
-
-Changes back to the original directory and removes the distribution
-directory (but not the temporary directory set during C<new()>).
-
- $dist = DistGen->new->chdir->regen;
- # ... do some testing ...
-
- $dist->remove->chdir_in->regen;
- # ... do more testing ...
-
-This is like a more aggressive form of C<clean>. Generally, calling C<clean>
-and C<regen> should be sufficient.
-
-=head2 Changing directories
-
-=head3 chdir_in
-
-Change directory into the dist root.
-
- $dist->chdir_in;
-
-=head3 chdir_original
-
-Returns to whatever directory you were in before chdir_in() (regardless
-of the cwd.)
-
- $dist->chdir_original;
-
-=head2 Command-line helpers
-
-These use Module::Build->run_perl_script() to ensure that Build.PL or Build are
-run in a separate process using the current perl interpreter. (Module::Build
-is loaded on demand). They also ensure appropriate naming for operating
-systems that require a suffix for Build.
-
-=head3 run_build_pl
-
-Runs Build.PL using the current perl interpreter. Any arguments are
-passed on the command line.
-
- $dist->run_build_pl('--quiet');
-
-=head3 run_build
-
-Runs Build using the current perl interpreter. Any arguments are
-passed on the command line.
-
- $dist->run_build(qw/test --verbose/);
-
-=head2 Properties
-
-=head3 name()
-
-Returns the name of the distribution.
-
- $dist->name: # e.g. Foo::Bar
-
-=head3 dirname()
-
-Returns the directory where the distribution is created.
-
- $dist->dirname; # e.g. t/_tmp/Simple
-
-=head2 Functions
-
-=head3 undent()
-
-Removes leading whitespace from a multi-line string according to the
-amount of whitespace on the first line.
-
- my $string = undent(" foo(\n bar => 'baz'\n )");
- $string eq "foo(
- bar => 'baz'
- )";
-
-=cut
-
-# vim:ts=2:sw=2:et:sta
+++ /dev/null
-package MBTest;
-
-use strict;
-
-use File::Spec;
-use File::Temp ();
-use File::Path ();
-
-
-# Setup the code to clean out %ENV
-BEGIN {
- # Environment variables which might effect our testing
- my @delete_env_keys = qw(
- HOME
- DEVEL_COVER_OPTIONS
- MODULEBUILDRC
- PERL_MB_OPT
- HARNESS_TIMER
- HARNESS_OPTIONS
- HARNESS_VERBOSE
- PREFIX
- INSTALL_BASE
- INSTALLDIRS
- );
-
- # Remember the ENV values because on VMS %ENV is global
- # to the user, not the process.
- my %restore_env_keys;
-
- sub clean_env {
- for my $key (@delete_env_keys) {
- if( exists $ENV{$key} ) {
- $restore_env_keys{$key} = delete $ENV{$key};
- }
- else {
- delete $ENV{$key};
- }
- }
- }
-
- END {
- while( my($key, $val) = each %restore_env_keys ) {
- $ENV{$key} = $val;
- }
- }
-}
-
-
-BEGIN {
- clean_env();
-
- # In case the test wants to use our other bundled
- # modules, make sure they can be loaded.
- my $t_lib = File::Spec->catdir('t', 'bundled');
- push @INC, $t_lib; # Let user's installed version override
-
- # We change directories, so expand @INC and $^X to absolute paths
- # Also add .
- @INC = (map(File::Spec->rel2abs($_), @INC), ".");
- $^X = File::Spec->rel2abs($^X);
-}
-
-use Exporter;
-use Test::More;
-use Config;
-use Cwd ();
-
-# We pass everything through to Test::More
-use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = 0.01_01;
-@ISA = qw(Test::More); # Test::More isa Exporter
-@EXPORT = @Test::More::EXPORT;
-%EXPORT_TAGS = %Test::More::EXPORT_TAGS;
-
-# We have a few extra exports, but Test::More has a special import()
-# that won't take extra additions.
-my @extra_exports = qw(
- stdout_of
- stderr_of
- stdout_stderr_of
- slurp
- find_in_path
- check_compiler
- have_module
- blib_load
- timed_out
-);
-push @EXPORT, @extra_exports;
-__PACKAGE__->export(scalar caller, @extra_exports);
-# XXX ^-- that should really happen in import()
-
-
-########################################################################
-
-# always return to the current directory
-{
- my $cwd;
- # must be done in BEGIN because tmpdir uses it in BEGIN for $ENV{HOME}
- BEGIN {
- $cwd = File::Spec->rel2abs(Cwd::cwd);
- }
-
- sub original_cwd { return $cwd }
-
- END {
- # Go back to where you came from!
- chdir $cwd or die "Couldn't chdir to $cwd";
- }
-}
-########################################################################
-
-{ # backwards compatible temp filename recipe adapted from perlfaq
- my $tmp_count = 0;
- my $tmp_base_name = sprintf("MB-%d-%d", $$, time());
- sub temp_file_name {
- sprintf("%s-%04d", $tmp_base_name, ++$tmp_count)
- }
-}
-########################################################################
-
-# Setup a temp directory
-sub tmpdir {
- my ($self, @args) = @_;
- my $dir = $ENV{PERL_CORE} ? MBTest->original_cwd : File::Spec->tmpdir;
- return File::Temp::tempdir('MB-XXXXXXXX', CLEANUP => 1, DIR => $dir, @args);
-}
-
-BEGIN {
- $ENV{HOME} = tmpdir; # don't want .modulebuildrc or other things interfering
-}
-
-sub save_handle {
- my ($handle, $subr) = @_;
- my $outfile = File::Spec->catfile(File::Spec->tmpdir, temp_file_name());
-
- local *SAVEOUT;
- open SAVEOUT, ">&" . fileno($handle)
- or die "Can't save output handle: $!";
- open $handle, "> $outfile" or die "Can't create $outfile: $!";
-
- eval {$subr->()};
- open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
-
- my $ret = slurp($outfile);
- 1 while unlink $outfile;
- return $ret;
-}
-
-sub stdout_of { save_handle(\*STDOUT, @_) }
-sub stderr_of { save_handle(\*STDERR, @_) }
-sub stdout_stderr_of {
- my $subr = shift;
- my ($stdout, $stderr);
- $stdout = stdout_of ( sub {
- $stderr = stderr_of( $subr )
- });
- return wantarray ? ($stdout, $stderr) : $stdout . $stderr;
-}
-
-sub slurp {
- open(my $fh, '<', $_[0]) or die "Can't open $_[0]: $!";
- local $/;
- return scalar <$fh>;
-}
-
-# Some extensions we should know about if we're looking for executables
-sub exe_exts {
-
- if ($^O eq 'MSWin32') {
- return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat');
- }
- if ($^O eq 'os2') {
- return qw(.exe .com .pl .cmd .bat .sh .ksh);
- }
- return;
-}
-
-sub find_in_path {
- my $thing = shift;
-
- my @exe_ext = exe_exts();
- if ( File::Spec->file_name_is_absolute( $thing ) ) {
- foreach my $ext ( '', @exe_ext ) {
- return "$thing$ext" if -e "$thing$ext";
- }
- }
- else {
- my @path = split $Config{path_sep}, $ENV{PATH};
- foreach (@path) {
- my $fullpath = File::Spec->catfile($_, $thing);
- foreach my $ext ( '', @exe_ext ) {
- return "$fullpath$ext" if -e "$fullpath$ext";
- }
- }
- }
- return;
-}
-
-sub check_compiler {
- if ($ENV{PERL_CORE}) {
- require IPC::Cmd;
- if ( $Config{usecrosscompile} && !IPC::Cmd::can_run($Config{cc}) ) {
- return;
- }
- else {
- return(1,1);
- }
- }
-
- local $SIG{__WARN__} = sub {};
-
- blib_load('Module::Build');
- my $mb = Module::Build->current;
- $mb->verbose( 0 );
-
- my $have_c_compiler;
- stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} );
- # XXX link_executable() is not yet implemented for Windows
- # and noexec tmpdir is irrelevant on Windows
- return ($have_c_compiler, 1) if $^O eq "MSWin32";
-
- # check noexec tmpdir
- my $tmp_exec;
- if ( $have_c_compiler ) {
- my $dir = MBTest->tmpdir;
- my $c_file = File::Spec->catfile($dir,'test.c');
- open my $fh, ">", $c_file;
- print {$fh} "int main() { return 0; }\n";
- close $fh;
- my $exe = $mb->cbuilder->link_executable(
- objects => $mb->cbuilder->compile( source => $c_file )
- );
- $tmp_exec = 0 == system( $exe );
- }
- return ($have_c_compiler, $tmp_exec);
-}
-
-sub have_module {
- my $module = shift;
- return eval "require $module; 1";
-}
-
-sub blib_load {
- # Load the given module and ensure it came from blib/, not the larger system
- my $mod = shift;
- have_module($mod) or die "Error loading $mod\: $@\n";
-
- (my $path = $mod) =~ s{::}{/}g;
- $path .= ".pm";
- my ($pkg, $file, $line) = caller;
- unless($ENV{PERL_CORE}) {
- unless($INC{$path} =~ m/\bblib\b/) {
- (my $load_from = $INC{$path}) =~ s{$path$}{};
- die "$mod loaded from '$load_from'\nIt should have been loaded from blib. \@INC contains:\n ",
- join("\n ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n";
- }
- }
-}
-
-sub timed_out {
- my ($sub, $timeout) = @_;
- return unless $sub;
- $timeout ||= 60;
-
- my $saw_alarm = 0;
- eval {
- local $SIG{ALRM} = sub { $saw_alarm++; die "alarm\n"; }; # NB: \n required
- alarm $timeout;
- $sub->();
- alarm 0;
- };
- if ($@) {
- die unless $@ eq "alarm\n"; # propagate unexpected errors
- }
- return $saw_alarm;
-}
-
-sub check_EUI {
- my $timed_out;
- stdout_stderr_of( sub {
- $timed_out = timed_out( sub {
- ExtUtils::Installed->new(extra_libs => [@INC])
- }
- );
- }
- );
- return ! $timed_out;
-}
-
-1;
-# vim:ts=2:sw=2:et:sta
+++ /dev/null
-package Module::Signature; # mocked
-use strict;
-use warnings;
-our $VERSION = 999;
-
-sub sign {
- open my $fh, ">", "SIGNATURE";
- print {$fh} "SIGNATURE";
-}
-
-1;
+++ /dev/null
-use strict;
-use warnings;
-
-package Software::License::VaporWare;
-our $VERSION = '0.001';
-
-use Software::License;
-our @ISA = qw/Software::License/;
-
-sub name { 'VaporWare License' }
-sub url { 'http://example.com/vaporware/' }
-sub meta_name { 'unrestricted' }
-sub meta2_name { 'unrestricted' }
-
-1;
-
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest;
-blib_load('Module::Build');
-blib_load('Module::Build::ConfigData');
-
-if ( Module::Build::ConfigData->feature('manpage_support') ) {
- plan tests => 21;
-} else {
- plan skip_all => 'manpage_support feature is not enabled';
-}
-
-
-#########################
-
-
-use Cwd ();
-my $cwd = Cwd::cwd;
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->add_file( 'bin/nopod.pl', <<'---' );
-#!perl -w
-print "sample script without pod to test manifypods action\n";
----
-$dist->add_file( 'bin/haspod.pl', <<'---' );
-#!perl -w
-print "Hello, world";
-
-__END__
-
-=head1 NAME
-
-haspod.pl - sample script with pod to test manifypods action
-
-=cut
----
-$dist->add_file( 'lib/Simple/NoPod.pm', <<'---' );
-package Simple::NoPod;
-1;
----
-$dist->add_file( 'lib/Simple/AllPod.pod', <<'---' );
-=head1 NAME
-
-Simple::AllPod - Pure POD
-
-=head1 AUTHOR
-
-Simple Man <simple@example.com>
-
-=cut
----
-$dist->regen;
-
-
-$dist->chdir_in;
-
-use File::Spec::Functions qw( catdir );
-my $destdir = catdir($cwd, 't', 'install_test' . $$);
-
-
-my $mb = Module::Build->new(
- module_name => $dist->name,
- install_base => $destdir,
- scripts => [ File::Spec->catfile( 'bin', 'nopod.pl' ),
- File::Spec->catfile( 'bin', 'haspod.pl' ) ],
-
- # Need default install paths to ensure manpages get generated
- installdirs => 'site',
- config => {
- installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'),
- installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'),
- }
-
-);
-
-$mb->add_to_cleanup($destdir);
-
-
-is( ref $mb->{properties}->{bindoc_dirs}, 'ARRAY', 'bindoc_dirs' );
-is( ref $mb->{properties}->{libdoc_dirs}, 'ARRAY', 'libdoc_dirs' );
-
-my %man = (
- sep => $mb->manpage_separator,
- dir1 => 'man1',
- dir3 => 'man3',
- ext1 => $mb->config('man1ext'),
- ext3 => $mb->config('man3ext'),
- );
-
-my %distro = (
- 'bin/nopod.pl' => '',
- 'bin/haspod.pl' => "haspod.pl.$man{ext1}",
- 'lib/Simple.pm' => "Simple.$man{ext3}",
- 'lib/Simple/NoPod.pm' => '',
- 'lib/Simple/AllPod.pod' => "Simple$man{sep}AllPod.$man{ext3}",
- );
-
-%distro = map {$mb->localize_file_path($_), $distro{$_}} keys %distro;
-
-my $lib_path = $mb->localize_dir_path('lib');
-
-# Remove trailing directory delimiter on VMS for compares
-$lib_path =~ s/\]// if $^O eq 'VMS';
-
-$mb->dispatch('build');
-
-eval {$mb->dispatch('docs')};
-is $@, '';
-
-while (my ($from, $v) = each %distro) {
- if (!$v) {
- ok ! $mb->contains_pod($from), "$from should not contain POD";
- next;
- }
-
- my $to = File::Spec->catfile('blib', ($from =~ /^[\.\/\[]*lib/ ? 'libdoc' : 'bindoc'), $v);
- ok $mb->contains_pod($from), "$from should contain POD";
- ok -e $to, "Created $to manpage";
-}
-
-
-$mb->dispatch('install');
-
-while (my ($from, $v) = each %distro) {
- next unless $v;
- my $to = File::Spec->catfile
- ($destdir, 'man', $man{($from =~ /^\Q$lib_path\E/ ? 'dir3' : 'dir1')}, $v);
- ok -e $to, "Created $to manpage";
-}
-
-$mb->dispatch('realclean');
-
-
-# revert to a pristine state
-$dist->regen( clean => 1 );
-
-my $mb2 = Module::Build->new(
- module_name => $dist->name,
- libdoc_dirs => [qw( foo bar baz )],
-);
-
-is( $mb2->{properties}->{libdoc_dirs}->[0], 'foo', 'override libdoc_dirs' );
-
-# Make sure we can find our own action documentation
-ok $mb2->get_action_docs('build');
-ok !eval{$mb2->get_action_docs('foo')};
-
-# Make sure those docs are the correct ones
-foreach ('testcover', 'disttest') {
- my $docs = $mb2->get_action_docs($_);
- like $docs, qr/=item $_/;
- unlike $docs, qr/\n=/, $docs;
-}
-
+++ /dev/null
-package ManifypodsWithUtf8;
-use strict;
-use utf8;
-use Test::More;
-
-use lib 't/lib';
-blib_load('Module::Build');
-blib_load('Module::Build::ConfigData');
-
-SKIP: {
- unless ( Module::Build::ConfigData->feature('manpage_support') ) {
- skip 'manpage_support feature is not enabled';
- }
-}
-
-use MBTest tests => 2;
-use File::Spec::Functions qw( catdir );
-
-use Cwd ();
-my $cwd = Cwd::cwd;
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-my $content = <<'---';
-
-=encoding utf8
-
-=head1 NAME
-
-Simple::PodWithUtf8 - POD with some (ç á à ô) special chars
-
-=cut
----
-utf8::encode($content);
-$dist->add_file( 'lib/Simple/PodWithUtf8.pod', $content);
-$dist->regen;
-$dist->chdir_in;
-
-my $destdir = catdir($cwd, 't', 'install_test' . $$);
-
-my $mb = Module::Build->new(
- module_name => $dist->name,
- install_base => $destdir,
-
- # need default install paths to ensure manpages get generated
- installdirs => 'site',
- config => {
- installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'),
- installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'),
- },
- extra_manify_args => { utf8 => 1 },
- );
-$mb->add_to_cleanup($destdir);
-
-
-$mb->dispatch('build');
-my $sep = $mb->manpage_separator;
-my $ext3 = $mb->config('man3ext');
-my $to = File::Spec->catfile('blib', 'libdoc', "Simple${sep}PodWithUtf8.${ext3}");
-
-ok(-e $to, "Manpage is found at $to");
-open my $pod, '<:encoding(utf-8)', $to or diag "Could not open $to: $!";
-my $pod_content = do { local $/; <$pod> };
-close $pod;
-
-like($pod_content, qr/ \(ç á à ô\) /, "POD should contain special characters");
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 14;
-
-blib_load('Module::Build');
-blib_load('Module::Build::ConfigData');
-
-my $tmp = MBTest->tmpdir;
-
-my %metadata =
- (
- module_name => 'Simple',
- dist_version => '3.14159265',
- dist_author => [ 'Simple Simon <ss\@somewhere.priv>' ],
- dist_abstract => 'Something interesting',
- test_requires => {
- 'Test::More' => 0.49,
- },
- license => 'perl',
- meta_add => {
- keywords => [qw(super duper something)],
- resources => {homepage => 'http://foo.example.com'},
- },
- );
-
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->change_build_pl( \%metadata );
-$dist->regen;
-
-my $simple_file = 'lib/Simple.pm';
-my $simple2_file = 'lib/Simple2.pm';
-
- # Traditional VMS will return the file in in lower case, and is_deeply
- # does exact case comparisons.
- # When ODS-5 support is active for preserved case file names we do not
- # change the case.
- if ($^O eq 'VMS') {
- my $lower_case_expect = 1;
- my $vms_efs_case = 0;
- if (eval 'require VMS::Feature') {
- $vms_efs_case = VMS::Feature::current("efs_case_preserve");
- } else {
- my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
- $vms_efs_case = $efs_case =~ /^[ET1]/i;
- }
- $lower_case_expect = 0 if $vms_efs_case;
- if ($lower_case_expect) {
- $simple_file = lc($simple_file);
- $simple2_file = lc($simple2_file);
- }
- }
-
-
-$dist->chdir_in;
-
-my $mb = Module::Build->new_from_context;
-
-##################################################
-#
-# Test for valid META.yml
-
-{
- my $mb_prereq = { 'Module::Build' => $Module::Build::VERSION };
- my $mb_config_req = {
- 'Module::Build' => sprintf '%2.2f', int($Module::Build::VERSION * 100)/100
- };
- my $node;
- my $output = stdout_stderr_of( sub {
- $node = $mb->get_metadata( auto => 1 );
- });
- like( $output, qr/Module::Build was not found in configure_requires/,
- "saw warning about M::B not in configure_requires"
- );
-
- # exists() doesn't seem to work here
- is $node->{name}, $metadata{module_name};
- is $node->{version}, $metadata{dist_version};
- is $node->{abstract}, $metadata{dist_abstract};
- is_deeply $node->{author}, $metadata{dist_author};
- is_deeply $node->{license}, [ 'perl_5' ];
- is_deeply $node->{prereqs}{configure}{requires}, $mb_config_req, 'Add M::B to configure_requires';
- is_deeply $node->{prereqs}{test}{requires}, {
- 'Test::More' => '0.49',
- }, 'Test::More was required by ->new';
- like $node->{generated_by}, qr{Module::Build};
- ok defined( $node->{'meta-spec'}{version} ),
- "'meta-spec' -> 'version' field present in META.yml";
- ok defined( $node->{'meta-spec'}{url} ),
- "'meta-spec' -> 'url' field present in META.yml";
- is_deeply $node->{keywords}, $metadata{meta_add}{keywords};
- is_deeply $node->{resources}, $metadata{meta_add}{resources};
-}
-
-{
- my $mb_prereq = { 'Module::Build' => 0 };
- $mb->configure_requires( $mb_prereq );
- my $node = $mb->get_metadata( auto => 1 );
-
-
- # exists() doesn't seem to work here
- is_deeply $node->{prereqs}{configure}{requires}, $mb_prereq, 'Add M::B to configure_requires';
-}
-
-$dist->clean;
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 18;
-
-blib_load('Module::Build');
-blib_load('Module::Build::ConfigData');
-
-use DistGen;
-
-
-############################## ACTION distmeta works without a MANIFEST file
-
-{
- my $dist = DistGen->new( no_manifest => 1 )->chdir_in->regen;
-
- ok ! -e 'MANIFEST';
-
- my $mb;
- stderr_of( sub { $mb = Module::Build->new_from_context } );
-
- my $out;
- $out = eval { stderr_of(sub{$mb->dispatch('distmeta')}) };
- is $@, '';
-
- like $out, qr/Nothing to enter for 'provides'/;
-
- ok -e 'META.yml';
-
-}
-
-
-############################## Check generation of README file
-
-# TODO: We need to test faking the absence of Pod::Readme when present
-# so Pod::Text will be used. Also fake the absence of both to
-# test that we fail gracefully.
-
-my $provides; # Used a bunch of times below
-
-my $pod_text = <<'---';
-=pod
-
-=head1 NAME
-
-Simple - A simple module
-
-=head1 AUTHOR
-
-Simple Simon <simon@simple.sim>
-
-=cut
----
-
-my $dist = DistGen->new->chdir_in;
-
-$dist->change_build_pl
-({
- module_name => $dist->name,
- dist_version => '3.14159265',
- license => 'perl',
- create_readme => 1,
-});
-
-# .pm File with pod
-#
-
-$dist->change_file( 'lib/Simple.pm', <<'---' . $pod_text);
-package Simple;
-$VERSION = '1.23';
----
-$dist->regen( clean => 1 );
-ok( -e "lib/Simple.pm", "Creating Simple.pm" );
-my $mb = Module::Build->new_from_context;
-$mb->do_create_readme;
-like( slurp("README"), qr/NAME/,
- "Generating README from .pm");
-is( $mb->dist_author->[0], 'Simple Simon <simon@simple.sim>',
- "Extracting AUTHOR from .pm");
-is( $mb->dist_abstract, "A simple module",
- "Extracting abstract from .pm");
-
-# .pm File with pod in separate file
-#
-
-$dist->change_file( 'lib/Simple.pm', <<'---');
-package Simple;
-$VERSION = '1.23';
----
-$dist->change_file( 'lib/Simple.pod', $pod_text );
-$dist->regen( clean => 1 );
-
-ok( -e "lib/Simple.pm", "Creating Simple.pm" );
-ok( -e "lib/Simple.pod", "Creating Simple.pod" );
-$mb = Module::Build->new_from_context;
-$mb->do_create_readme;
-like( slurp("README"), qr/NAME/, "Generating README from .pod");
-is( $mb->dist_author->[0], 'Simple Simon <simon@simple.sim>',
- "Extracting AUTHOR from .pod");
-is( $mb->dist_abstract, "A simple module",
- "Extracting abstract from .pod");
-
-# .pm File with pod and separate pod file
-#
-
-$dist->change_file( 'lib/Simple.pm', <<'---' );
-package Simple;
-$VERSION = '1.23';
-
-=pod
-
-=head1 DONT USE THIS FILE FOR POD
-
-=cut
----
-$dist->change_file( 'lib/Simple.pod', $pod_text );
-$dist->regen( clean => 1 );
-ok( -e "lib/Simple.pm", "Creating Simple.pm" );
-ok( -e "lib/Simple.pod", "Creating Simple.pod" );
-$mb = Module::Build->new_from_context;
-$mb->do_create_readme;
-like( slurp("README"), qr/NAME/, "Generating README from .pod over .pm");
-is( $mb->dist_author->[0], 'Simple Simon <simon@simple.sim>',
- "Extracting AUTHOR from .pod over .pm");
-is( $mb->dist_abstract, "A simple module",
- "Extracting abstract from .pod over .pm");
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use CPAN::Meta 2.110420;
-use CPAN::Meta::YAML;
-use Parse::CPAN::Meta 1.4401;
-plan tests => 39;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->change_file('Build.PL', <<"---");
-use strict;
-use Module::Build;
-
-my \$builder = Module::Build->new(
- module_name => '$dist->{name}',
- license => 'perl',
- requires => {
- 'File::Spec' => ( \$ENV{BUMP_PREREQ} ? 0.86 : 0 ),
- },
- configure_requires => {
- 'Module::Build' => '0.42',
- }
-);
-
-\$builder->create_build_script();
----
-$dist->regen;
-$dist->chdir_in;
-
-#########################
-
-# Test MYMETA generation
-{
- ok( ! -e "META.yml", "META.yml doesn't exist before Build.PL runs" );
- ok( ! -e "MYMETA.yml", "MYMETA.yml doesn't exist before Build.PL runs" );
- ok( ! -e "META.json", "META.json doesn't exist before Build.PL runs" );
- ok( ! -e "MYMETA.json", "MYMETA.json doesn't exist before Build.PL runs" );
- my $output;
- $output = stdout_of sub { $dist->run_build_pl };
- like($output, qr/Created MYMETA\.yml and MYMETA\.json/,
- "Ran Build.PL and saw MYMETA.yml creation message"
- );
- ok( -e "MYMETA.yml", "MYMETA.yml exists" );
- ok( -e "MYMETA.json", "MYMETA.json exists" );
-}
-
-#########################
-
-# Test interactions between META/MYMETA
-{
- my $output = stdout_stderr_of sub { $dist->run_build('distmeta') };
- like($output, qr/Created META\.yml and META\.json/,
- "Ran Build distmeta to create META.yml");
- # regenerate MYMETA to pick up from META instead of creating from scratch
- $output = stdout_of sub { $dist->run_build_pl };
- like($output, qr/Created MYMETA\.yml and MYMETA\.json/,
- "Re-ran Build.PL and regenerated MYMETA.yml based on META.yml"
- );
-
- for my $suffix ( qw/.yml .json/ ) {
- my $meta = Parse::CPAN::Meta->load_file("META$suffix");
- my $mymeta = Parse::CPAN::Meta->load_file("MYMETA$suffix");
- is( delete $meta->{dynamic_config}, 1,
- "META$suffix 'dynamic_config' is 1"
- );
- is( delete $mymeta->{dynamic_config}, 0,
- "MYMETA$suffix 'dynamic_config' is 0"
- );
- is_deeply( $mymeta, $meta, "Other generated MYMETA$suffix matches generated META$suffix" )
- or do {
- require Data::Dumper;
- diag "MYMETA:\n" . Data::Dumper::Dumper($mymeta)
- . "META:\n" . Data::Dumper::Dumper($meta);
- };
- }
-
- $output = stdout_stderr_of sub { $dist->run_build('realclean') };
- like( $output, qr/Cleaning up/, "Ran realclean");
- ok( ! -e 'Build', "Build file removed" );
- ok( ! -e 'MYMETA.yml', "MYMETA.yml file removed" );
- ok( ! -e 'MYMETA.json', "MYMETA.json file removed" );
-
- # test that dynamic prereq is picked up
- my $meta = Parse::CPAN::Meta->load_file("META.yml");
- my $meta2 = Parse::CPAN::Meta->load_file("META.json");
- local $ENV{BUMP_PREREQ} = 1;
- $output = stdout_of sub { $dist->run_build_pl };
- like($output, qr/Created MYMETA\.yml and MYMETA\.json/,
- "Ran Build.PL with dynamic config"
- );
- ok( -e "MYMETA.yml", "MYMETA.yml exists" );
- ok( -e "MYMETA.json", "MYMETA.json exists" );
- my $mymeta = Parse::CPAN::Meta->load_file('MYMETA.yml');
- my $mymeta2 = Parse::CPAN::Meta->load_file('MYMETA.json');
- isnt( $meta->{requires}{'File::Spec'},
- $mymeta->{requires}{'File::Spec'},
- "MYMETA.yml requires differs from META.yml"
- );
- isnt( $meta2->{prereqs}{runtime}{requires}{'File::Spec'},
- $mymeta2->{prereqs}{runtime}{requires}{'File::Spec'},
- "MYMETA.json requires differs from META.json"
- );
- $output = stdout_stderr_of sub { $dist->run_build('realclean') };
- like( $output, qr/Cleaning up/, "Ran realclean");
- ok( ! -e 'Build', "Build file removed" );
- ok( ! -e 'MYMETA.yml', "MYMETA file removed" );
- ok( ! -e 'MYMETA.json', "MYMETA file removed" );
-
- # manually change META and check that changes are preserved
- $meta->{author} = ['John Gault'];
- $meta2->{author} = ['John Gault'];
- ok( CPAN::Meta::YAML->new($meta)->write('META.yml'),
- "Wrote manually modified META.yml" );
- ok( CPAN::Meta->new( $meta2 )->save('META.json'),
- "Wrote manually modified META.json" );
-
- $output = stdout_of sub { $dist->run_build_pl };
- like($output, qr/Created MYMETA\.yml and MYMETA\.json/,
- "Ran Build.PL"
- );
- $mymeta = Parse::CPAN::Meta->load_file('MYMETA.yml');
- $mymeta2 = Parse::CPAN::Meta->load_file('MYMETA.json');
- is_deeply( $mymeta->{author}, [ 'John Gault' ],
- "MYMETA.yml preserved META.yml modifications"
- );
- is_deeply( $mymeta2->{author}, [ 'John Gault' ],
- "MYMETA.json preserved META.json modifications"
- );
-
-}
-
-#########################
-
-# Test cleanup
-{
- my $output = stdout_stderr_of sub { $dist->run_build('distcheck') };
- like($output, qr/Creating a temporary 'MANIFEST.SKIP'/,
- "MANIFEST.SKIP created for distcheck"
- );
- unlike($output, qr/MYMETA/,
- "MYMETA not flagged by distcheck"
- );
-}
-
-
-{
- my $output = stdout_of sub { $dist->run_build_pl };
- like($output, qr/Created MYMETA\.yml and MYMETA\.json/,
- "Ran Build.PL and saw MYMETA.yml creation message"
- );
- $output = stdout_stderr_of sub { $dist->run_build('distclean') };
- ok( ! -f 'MYMETA.yml', "No MYMETA.yml after distclean" );
- ok( ! -f 'MYMETA.json', "No MYMETA.json after distclean" );
- ok( ! -f 'MANIFEST.SKIP', "No MANIFEST.SKIP after distclean" );
-}
-
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 2;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-
-my $libdir = 'badlib';
-$dist->add_file("$libdir/Build.PL", 'die');
-$dist->regen;
-
-$dist->chdir_in;
-
-
-unshift(@INC, $libdir);
-my $mb = eval { Module::Build->new_from_context};
-ok(! $@, 'dodged the bullet') or die;
-ok($mb);
-
-# vim:ts=2:sw=2:et:sta
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 11;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-$dist->chdir_in;
-
-
-###################################
-$dist->change_file( 'Build.PL', <<"---" );
-use Module::Build;
-my \$build = Module::Build->new(
- module_name => @{[$dist->name]},
- license => 'perl'
-);
-\$build->create_build_script;
-\$build->notes(foo => 'bar');
----
-
-$dist->regen;
-
-my $mb = Module::Build->new_from_context;
-
-is $mb->notes('foo'), 'bar';
-
-# Try setting & checking a new value
-$mb->notes(argh => 'new');
-is $mb->notes('argh'), 'new';
-
-# Change existing value
-$mb->notes(foo => 'foo');
-is $mb->notes('foo'), 'foo';
-
-# Change back so we can run this test again successfully
-$mb->notes(foo => 'bar');
-is $mb->notes('foo'), 'bar';
-
-# Check undef vs. 0 vs ''
-foreach my $val (undef, 0, '') {
- $mb->notes(null => $val);
- is $mb->notes('null'), $val;
-}
-
-
-###################################
-# Make sure notes set before create_build_script() get preserved
-$mb = Module::Build->new(module_name => $dist->name);
-ok $mb;
-$mb->notes(foo => 'bar');
-is $mb->notes('foo'), 'bar';
-
-$mb->create_build_script;
-
-$mb = Module::Build->resume;
-ok $mb;
-is $mb->notes('foo'), 'bar';
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 26;
-
-blib_load('Module::Build');
-
-#########################
-
-package Foo;
-sub foo;
-
-package MySub1;
-use base 'Module::Build';
-
-package MySub2;
-use base 'MySub1';
-
-package MySub3;
-use base qw(MySub2 Foo);
-
-package MyTest;
-use base 'Module::Build';
-
-package MyBulk;
-use base qw(MySub2 MyTest);
-
-package main;
-
-ok my @parents = MySub1->mb_parents;
-# There will be at least one platform class in between.
-ok @parents >= 2;
-# They should all inherit from Module::Build::Base;
-ok ! grep { !$_->isa('Module::Build::Base') } @parents;
-is $parents[0], 'Module::Build';
-is $parents[-1], 'Module::Build::Base';
-
-ok @parents = MySub2->mb_parents;
-ok @parents >= 3;
-ok ! grep { !$_->isa('Module::Build::Base') } @parents;
-is $parents[0], 'MySub1';
-is $parents[1], 'Module::Build';
-is $parents[-1], 'Module::Build::Base';
-
-ok @parents = MySub3->mb_parents;
-ok @parents >= 4;
-ok ! grep { !$_->isa('Module::Build::Base') } @parents;
-is $parents[0], 'MySub2';
-is $parents[1], 'MySub1';
-is $parents[2], 'Module::Build';
-is $parents[-1], 'Module::Build::Base';
-
-ok @parents = MyBulk->mb_parents;
-ok @parents >= 5;
-ok ! grep { !$_->isa('Module::Build::Base') } @parents;
-is $parents[0], 'MySub2';
-is $parents[1], 'MySub1';
-is $parents[2], 'Module::Build';
-is $parents[-2], 'Module::Build::Base';
-is $parents[-1], 'MyTest';
+++ /dev/null
-# sample.t -- a sample test file for Module::Build
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-plan tests => 8; # or 'no_plan'
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-# create dist object in a temp directory
-# enter the directory and generate the skeleton files
-my $dist = DistGen->new->chdir_in->regen;
-
-$dist->add_file('t/subtest/foo.t', <<'END_T');
-use strict;
-use Test::More tests => 1;
-ok(1, "this is a recursive test");
-END_T
-
-$dist->regen;
-
-# get a Module::Build object and test with it
-my $mb = $dist->new_from_context(); # quiet by default
-isa_ok( $mb, "Module::Build" );
-is( $mb->dist_name, "Simple", "dist_name is 'Simple'" );
-ok( ! $mb->recursive_test_files, "set for no recursive testing" );
-
-# set for recursive testing using PERL_MB_OPT
-{
- local $ENV{PERL_MB_OPT} = "--verbose --recursive_test_files 1";
-
- my $out = stdout_stderr_of( sub {
- $dist->run_build('test');
- });
- like( $out, qr/this is a recursive test/,
- "recursive tests run via PERL_MB_OPT"
- );
-}
-
-# set Build.PL opts using PERL_MB_OPT
-{
- local $ENV{PERL_MB_OPT} = "--verbose --recursive_test_files 1";
- my $mb = $dist->new_from_context(); # quiet by default
- ok( $mb->recursive_test_files, "PERL_MB_OPT set recusive tests in Build.PL" );
- ok( $mb->verbose, "PERL_MB_OPT set verbose in Build.PL" );
-}
-
-# verify settings preserved during 'Build test'
-{
- ok( !$ENV{PERL_MB_OPT}, "PERL_MB_OPT cleared" );
- my $out = stdout_stderr_of( sub {
- $dist->run_build('test');
- });
- like( $out, qr/this is a recursive test/,
- "recursive tests run via Build object"
- );
-}
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 14;
-
-blib_load('Module::Build::PodParser');
-
-#########################
-
-{
- package IO::StringBased;
-
- sub TIEHANDLE {
- my ($class, $string) = @_;
- return bless {
- data => [ map "$_\n", split /\n/, $string],
- }, $class;
- }
-
- sub READLINE {
- shift @{ shift()->{data} };
- }
-}
-
-local *FH;
-tie *FH, 'IO::StringBased', <<'EOF';
-=head1 NAME
-
-Foo::Bar - Perl extension for blah blah blah
-
-=head1 AUTHOR
-
-C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.
-
-Home page: http://example.com/~eh/
-
-=cut
-EOF
-
-
-my $pp = Module::Build::PodParser->new(fh => \*FH);
-ok $pp, 'object created';
-
-is $pp->get_author->[0], 'C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.', 'author';
-is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract';
-
-
-{
- # Try again without a valid author spec
- untie *FH;
- tie *FH, 'IO::StringBased', <<'EOF';
-=head1 NAME
-
-Foo::Bar - Perl extension for blah blah blah
-
-=cut
-EOF
-
- my $pp = Module::Build::PodParser->new(fh => \*FH);
- ok $pp, 'object created';
-
- is_deeply $pp->get_author, [], 'author';
- is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract';
-}
-
-
-{
- # Try again with mixed-case =head1s.
- untie *FH;
- tie *FH, 'IO::StringBased', <<'EOF';
-=head1 Name
-
-Foo::Bar - Perl extension for blah blah blah
-
-=head1 Author
-
-C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.
-
-Home page: http://example.com/~eh/
-
-=cut
-EOF
-
- my $pp = Module::Build::PodParser->new(fh => \*FH);
- ok $pp, 'object created';
-
- is $pp->get_author->[0], 'C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.', 'author';
- is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract';
-}
-
-
-{
- # Now with C<Module::Name>
- untie *FH;
- tie *FH, 'IO::StringBased', <<'EOF';
-=head1 Name
-
-C<Foo::Bar> - Perl extension for blah blah blah
-
-=head1 Author
-
-C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.
-
-Home page: http://example.com/~eh/
-
-=cut
-EOF
-
- my $pp = Module::Build::PodParser->new(fh => \*FH);
- ok $pp, 'object created';
-
- is $pp->get_author->[0], 'C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.', 'author';
- is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract';
-}
-
-{
-local *FH;
-tie *FH, 'IO::StringBased', <<'EOF';
-=head1 NAME
-
-Foo_Bar - Perl extension for eating pie
-
-=head1 AUTHOR
-
-C<Foo_Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.
-
-Home page: http://example.com/~eh/
-
-=cut
-EOF
-
-
- my $pp = Module::Build::PodParser->new(fh => \*FH);
- ok $pp, 'object created';
- is $pp->get_abstract, 'Perl extension for eating pie', 'abstract';
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use Config;
-
-blib_load('Module::Build');
-blib_load('Module::Build::ConfigData');
-my $PPM_support = Module::Build::ConfigData->feature('PPM_support');
-my $manpage_support = Module::Build::ConfigData->feature('manpage_support');
-my $HTML_support = Module::Build::ConfigData->feature('HTML_support');
-
-my $tmp;
-
-{
- my ($have_c_compiler, $tmp_exec) = check_compiler();
- if ( ! $have_c_compiler ) {
- plan skip_all => 'No compiler found';
- } elsif ( ! $PPM_support ) {
- plan skip_all => 'PPM support modules not installed';
- } elsif ( !$Config{usedl} ) {
- plan skip_all => 'Perl not compiled for dynamic loading';
- } elsif ( ! $HTML_support ) {
- plan skip_all => "HTML support not installed";
- } elsif ( ! eval {require Archive::Tar} ) {
- plan skip_all => "Archive::Tar not installed to read archives.";
- } elsif ( ! eval {IO::Zlib->VERSION(1.01)} ) {
- plan skip_all => "IO::Zlib 1.01 required to read compressed archives.";
- } elsif ( $^O eq 'VMS' ) {
- plan skip_all => "Needs porting work on VMS";
- } else {
- plan tests => 12;
- }
- require Cwd;
- $tmp = MBTest->tmpdir( $tmp_exec ? () : (DIR => Cwd::cwd) );
-}
-
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp, xs => 1 );
-$dist->add_file( 'hello', <<'---' );
-#!perl -w
-print "Hello, World!\n";
-__END__
-
-=pod
-
-=head1 NAME
-
-hello
-
-=head1 DESCRIPTION
-
-Says "Hello"
-
-=cut
----
-$dist->change_build_pl
-({
- module_name => $dist->name,
- license => 'perl',
- scripts => [ 'hello' ],
-});
-$dist->regen;
-
-$dist->chdir_in;
-
-use File::Spec::Functions qw(catdir);
-
-my @installstyle = qw(lib perl5);
-my $mb = Module::Build->new_from_context(
- verbose => 0,
- quiet => 1,
-
- installdirs => 'site',
- config => {
- manpage_reset(), html_reset(),
- ( $manpage_support ?
- ( installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'),
- installsiteman3dir => catdir($tmp, 'site', 'man', 'man3') ) : () ),
- ( $HTML_support ?
- ( installsitehtml1dir => catdir($tmp, 'site', 'html'),
- installsitehtml3dir => catdir($tmp, 'site', 'html') ) : () ),
- },
- html_links => 0,
-);
-
-
-
-$mb->dispatch('ppd', args => {codebase => '/path/to/codebase-xs'});
-
-(my $dist_filename = $dist->name) =~ s/::/-/g;
-my $ppd = slurp($dist_filename . '.ppd');
-
-my $perl_version = Module::Build::PPMMaker->_ppd_version($mb->perl_version);
-my $varchname = Module::Build::PPMMaker->_varchname($mb->config);
-
-# This test is quite a hack since with XML you don't really want to
-# do a strict string comparison, but absent an XML parser it's the
-# best we can do.
-is $ppd, <<"---";
-<SOFTPKG NAME="$dist_filename" VERSION="0.01">
- <ABSTRACT>Perl extension for blah blah blah</ABSTRACT>
- <AUTHOR>A. U. Thor, a.u.thor\@a.galaxy.far.far.away</AUTHOR>
- <IMPLEMENTATION>
- <ARCHITECTURE NAME="$varchname" />
- <CODEBASE HREF="/path/to/codebase-xs" />
- </IMPLEMENTATION>
-</SOFTPKG>
----
-
-
-
-$mb->dispatch('ppmdist');
-is $@, '';
-
-my $tar = Archive::Tar->new;
-
-my $tarfile = $mb->ppm_name . '.tar.gz';
-$tar->read( $tarfile, 1 );
-
-my $files = { map { $_ => 1 } $tar->list_files };
-
-my $fname = 'Simple';
-$fname = DynaLoader::mod2fname([$fname]) if defined &DynaLoader::mod2fname;
-exists_ok($files, "blib/arch/auto/Simple/$fname." . $mb->config('dlext'));
-exists_ok($files, 'blib/lib/Simple.pm');
-exists_ok($files, 'blib/script/hello');
-
-SKIP: {
- skip( "manpage_support not enabled.", 2 ) unless $manpage_support;
-
- exists_ok($files, 'blib/man3/Simple.' . $mb->config('man3ext'));
- exists_ok($files, 'blib/man1/hello.' . $mb->config('man1ext'));
-}
-
-SKIP: {
- skip( "HTML_support not enabled.", 2 ) unless $HTML_support;
-
- exists_ok($files, 'blib/html/site/lib/Simple.html');
- exists_ok($files, 'blib/html/bin/hello.html');
-}
-
-$tar->clear;
-undef( $tar );
-
-$mb->dispatch('realclean');
-$dist->clean;
-
-
-SKIP: {
- skip( "HTML_support not enabled.", 3 ) unless $HTML_support;
-
- # Make sure html documents are generated for the ppm distro even when
- # they would not be built during a normal build.
- $mb = Module::Build->new_from_context(
- verbose => 0,
- quiet => 1,
-
- installdirs => 'site',
- config => {
- html_reset(),
- installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'),
- installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'),
- },
- html_links => 0,
- );
-
- $mb->dispatch('ppmdist');
- is $@, '';
-
- $tar = Archive::Tar->new;
- $tar->read( $tarfile, 1 );
-
- $files = {map { $_ => 1 } $tar->list_files};
-
- exists_ok($files, 'blib/html/site/lib/Simple.html');
- exists_ok($files, 'blib/html/bin/hello.html');
-
- $tar->clear;
-
- $mb->dispatch('realclean');
- $dist->clean;
-}
-
-
-########################################
-
-sub exists_ok {
- my $files = shift;
- my $file = shift;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- ok exists( $files->{$file} ) && $files->{$file}, $file;
-}
-
-# A hash of all Config.pm settings related to installing
-# manpages with values set to an empty string.
-sub manpage_reset {
- return (
- installman1dir => '',
- installman3dir => '',
- installsiteman1dir => '',
- installsiteman3dir => '',
- installvendorman1dir => '',
- installvendorman3dir => '',
- );
-}
-
-# A hash of all Config.pm settings related to installing
-# html documents with values set to an empty string.
-sub html_reset {
- return (
- installhtmldir => '',
- installhtml1dir => '',
- installhtml3dir => '',
- installsitehtml1dir => '',
- installsitehtml3dir => '',
- installvendorhtml1dir => '',
- installvendorhtml3dir => '',
- );
-}
-
+++ /dev/null
-# sample.t -- a sample test file for Module::Build
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-plan tests => 2;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-#--------------------------------------------------------------------------#
-# Create test distribution
-#--------------------------------------------------------------------------#
-
-use DistGen;
-my $dist = DistGen->new( name => 'Simple::Name' );
-
-$dist->change_build_pl(
- module_name => 'Simple::Name',
- dist_suffix => 'SUFFIX',
-)->regen;
-
-$dist->chdir_in;
-
-my $mb = $dist->new_from_context();
-isa_ok( $mb, "Module::Build" );
-is( $mb->dist_dir, "Simple-Name-0.01-SUFFIX",
- "dist_suffix set correctly"
-);
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-plan 'no_plan';
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-#--------------------------------------------------------------------------#
-# Create test distribution
-#--------------------------------------------------------------------------#
-
-{
- my $dist = DistGen->new(
- name => 'Simple::Name',
- version => '0.01',
- license => 'perl'
- );
-
- $dist->regen;
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->license, 'perl',
- "license 'perl' is valid"
- );
-
- my $meta = $mb->get_metadata( fatal => 0 );
-
- is_deeply( $meta->{license} => [ 'perl_5' ], "META license will be 'perl'" );
- is_deeply( $meta->{resources}{license}, [ "http://dev.perl.org/licenses/" ],
- "META license URL is correct"
- );
-
-}
-
-{
- my $dist = DistGen->new(
- name => 'Simple::Name',
- version => '0.01',
- license => 'VaporWare'
- );
-
- $dist->regen;
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->license, 'VaporWare',
- "license 'VaporWare' is valid"
- );
-
- my $meta = $mb->get_metadata( fatal => 0 );
-
- is_deeply( $meta->{license} => [ 'unrestricted' ], "META license will be 'unrestricted'" );
- is_deeply( $meta->{resources}{license}, [ "http://example.com/vaporware/" ],
- "META license URL is correct"
- );
-
-}
-
-# Test with alpha number
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-# sample.t -- a sample test file for Module::Build
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-plan tests => 4;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-my $dist;
-
-#--------------------------------------------------------------------------#
-# try getting module_name from dist_name
-#--------------------------------------------------------------------------#
-
-$dist = DistGen->new(
- name => "Not::So::Simple",
- distdir => 'Random-Name',
-)->chdir_in;
-
-$dist->change_build_pl(
- dist_name => 'Not-So-Simple',
- dist_version => 1,
-)->regen;
-
-my $mb = $dist->new_from_context();
-isa_ok( $mb, "Module::Build" );
-is( $mb->module_name, "Not::So::Simple",
- "module_name guessed from dist_name"
-);
-
-#--------------------------------------------------------------------------#
-# Try getting module_name from dist_version_from
-#--------------------------------------------------------------------------#
-
-$dist->add_file( 'lib/Simple/Name.pm', << 'END_PACKAGE' );
-package Simple::Name;
-our $VERSION = 1.23;
-1;
-END_PACKAGE
-
-$dist->change_build_pl(
- dist_name => 'Random-Name',
- dist_version_from => 'lib/Simple/Name.pm',
- dist_abstract => "Don't complain about missing abstract",
-)->regen( clean => 1 );
-
-$mb = $dist->new_from_context();
-isa_ok( $mb, "Module::Build" );
-is( $mb->module_name, "Simple::Name",
- "module_name guessed from dist_version_from"
-);
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-# sample.t -- a sample test file for Module::Build
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-plan tests => 19;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-my $dist = DistGen->new->regen->chdir_in;
-
-# get a Module::Build object and test with it
-my $mb;
-stderr_of(sub {
- ok( $mb = $dist->new_from_context, "Default Build.PL" );
-});
-
-ok( ! $mb->needs_compiler, "needs_compiler is false" );
-ok( ! exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'},
- "ExtUtils::CBuilder is not in build_requires"
-);
-
-#--------------------------------------------------------------------------#
-# try with c_source
-#--------------------------------------------------------------------------#
-$dist->change_build_pl({
- module_name => $dist->name,
- license => 'perl',
- c_source => 'src',
-});
-$dist->regen;
-stderr_of(sub {
- ok( $mb = $dist->new_from_context,
- "Build.PL with c_source"
- );
-});
-is( $mb->c_source, 'src', "c_source is set" );
-ok( $mb->needs_compiler, "needs_compiler is true" );
-ok( exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'},
- "ExtUtils::CBuilder was added to build_requires"
-);
-
-#--------------------------------------------------------------------------#
-# try with xs files
-#--------------------------------------------------------------------------#
-$dist = DistGen->new(dir => 'MBTest', xs => 1);
-$dist->regen;
-$dist->chdir_in;
-
-stderr_of(sub {
- ok( $mb = $dist->new_from_context,
- "Build.PL with xs files"
- );
-});
-ok( $mb->needs_compiler, "needs_compiler is true" );
-ok( exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'},
- "ExtUtils::CBuilder was added to build_requires"
-);
-
-#--------------------------------------------------------------------------#
-# force needs_compiler off, despite xs modules
-#--------------------------------------------------------------------------#
-
-$dist->change_build_pl({
- module_name => $dist->name,
- license => 'perl',
- needs_compiler => 0,
-});
-$dist->regen;
-
-stderr_of(sub {
- ok( $mb = $dist->new_from_context ,
- "Build.PL with xs files, but needs_compiler => 0"
- );
-});
-is( $mb->needs_compiler, 0, "needs_compiler is false" );
-ok( ! exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'},
- "ExtUtils::CBuilder is not in build_requires"
-);
-
-#--------------------------------------------------------------------------#
-# don't override specific EU::CBuilder build_requires
-#--------------------------------------------------------------------------#
-
-$dist->change_build_pl({
- module_name => $dist->name,
- license => 'perl',
- build_requires => { 'ExtUtils::CBuilder' => 0.2 },
-});
-$dist->regen;
-
-stderr_of(sub {
- ok( $mb = $dist->new_from_context ,
- "Build.PL with xs files, build_requires EU::CB 0.2"
- );
-});
-ok( $mb->needs_compiler, "needs_compiler is true" );
-is( $mb->build_requires->{'ExtUtils::CBuilder'}, 0.2,
- "build_requires for ExtUtils::CBuilder is correct version"
-);
-
-#--------------------------------------------------------------------------#
-# falsify compiler and test error handling
-#--------------------------------------------------------------------------#
-
-# clear $ENV{CC} so we are sure to fail to find our fake compiler :-)
-local $ENV{CC};
-
-my $err = stderr_of( sub {
- $mb = $dist->new_from_context( config => { cc => "adfasdfadjdjk" } )
-});
-ok( $mb, "Build.PL while hiding compiler" );
-like( $err, qr/no compiler detected/,
- "hidden compiler resulted in warning message during Build.PL"
-);
-eval { $mb->dispatch('build') };
-like( $@, qr/no compiler detected/,
- "hidden compiler resulted in fatal message during Build"
-);
-
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-if ( $] lt 5.008001 ) {
- plan skip_all => "dotted-version numbers are buggy before 5.8.1";
-} else {
- plan 'no_plan';
-}
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-#--------------------------------------------------------------------------#
-# Create test distribution
-#--------------------------------------------------------------------------#
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => '0.01' );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->release_status, "stable",
- "regular version has release_status 'stable'"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => 'v1.2.3' );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->release_status, "stable",
- "dotted-decimal version has release_status 'stable'"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => q{'0.01_01'} );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->release_status, "testing",
- "alpha version has release_status 'testing'"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => 'v1.2.3_1' );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->release_status, "testing",
- "dotted alpha version has release_status 'testing'"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => q{'0.01_01'} );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- release_status => 'unstable',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->release_status, "unstable",
- "explicit 'unstable' keeps release_status 'unstable'"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => '0.01' );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- release_status => 'testing',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->dist_suffix, "TRIAL",
- "regular version marked 'testing' gets 'TRIAL' suffix"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => 'v1.2.3' );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- release_status => 'testing',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->dist_suffix, "TRIAL",
- "dotted version marked 'testing' gets 'TRIAL' suffix"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => '0.01' );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- release_status => 'unstable',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->dist_suffix, "TRIAL",
- "regular version marked 'unstable' gets 'TRIAL' suffix"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => '0.01' );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- release_status => 'beta',
- )->regen;
-
- $dist->chdir_in;
-
- my $output = stdout_stderr_of sub { $dist->run_build_pl() };
- like( $output, qr/Illegal value 'beta' for release_status/i,
- "Got error message for illegal release_status"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => q{'0.01_01'} );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- release_status => 'stable',
- )->regen;
-
- $dist->chdir_in;
-
- my $output = stdout_stderr_of sub { $dist->run_build_pl() };
- like( $output, qr/Illegal value 'stable' with version '0.01_01'/i,
- "Got error message for illegal 'stable' with alpha version"
- );
-}
-
-{
- my $dist = DistGen->new( name => 'Simple::Name', version => q{'0.01_01'} );
-
- $dist->change_build_pl(
- module_name => 'Simple::Name',
- dist_version => '1.23beta1',
- )->regen;
-
- $dist->chdir_in;
-
- my $mb = $dist->new_from_context();
- isa_ok( $mb, "Module::Build" );
- is( $mb->dist_suffix, "",
- "non-standard dist_version does not get a suffix"
- );
- is( $mb->release_status, "stable",
- "non-standard dist_version defaults to stable release_status"
- );
-}
-
-# Test with alpha number
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-# sample.t -- a sample test file for Module::Build
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use DistGen;
-
-plan tests => 4;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-my ($dist, $mb, $prereqs);
-
-#--------------------------------------------------------------------------#
-# try undefined prereq version
-#--------------------------------------------------------------------------#
-
-$dist = DistGen->new( name => 'Simple::Requires' );
-
-$dist->change_build_pl(
- module_name => 'Simple::Requires',
- requires => {
- 'File::Basename' => undef,
- },
-)->regen;
-
-$dist->chdir_in;
-
-$mb = $dist->new_from_context();
-isa_ok( $mb, "Module::Build" );
-
-$prereqs = $mb->_normalize_prereqs;
-is($prereqs->{runtime}{requires}{'File::Basename'}, 0, "undef prereq converted to 0");
-
-#--------------------------------------------------------------------------#
-# try empty string prereq version
-#--------------------------------------------------------------------------#
-
-$dist->change_build_pl(
- module_name => 'Simple::Requires',
- requires => {
- 'File::Basename' => '',
- },
-)->regen;
-
-$mb = $dist->new_from_context();
-isa_ok( $mb, "Module::Build" );
-
-$prereqs = $mb->_normalize_prereqs;
-is($prereqs->{runtime}{requires}{'File::Basename'}, 0, "empty string prereq converted to 0");
-
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use File::Spec::Functions qw/catdir catfile/;
-
-#--------------------------------------------------------------------------#
-# Begin testing
-#--------------------------------------------------------------------------#
-
-plan tests => 23;
-
-blib_load('Module::Build');
-
-#--------------------------------------------------------------------------#
-# Create test distribution
-#--------------------------------------------------------------------------#
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp, name => 'Simple::Share' );
-$dist->regen;
-$dist->chdir_in;
-
-#--------------------------------------------------------------------------#
-# Test setting 'share_dir'
-#--------------------------------------------------------------------------#
-
-my $mb = $dist->new_from_context;
-
-# Test without a 'share' dir
-ok( $mb, "Created Module::Build object" );
-is( $mb->share_dir, undef,
- "default share_dir undef if no 'share' dir exists"
-);
-ok( ! exists $mb->{properties}{requires}{'File::ShareDir'},
- "File::ShareDir not added to 'requires'"
-);
-
-# Add 'share' dir and an 'other' dir and content
-$dist->add_file('share/foo.txt',<< '---');
-This is foo.txt
----
-$dist->add_file('share/subdir/share/anotherbar.txt',<< '---');
-This is anotherbar.txt in a subdir - test for a bug in M::B 0.38 when full path contains 'share/.../*share/...' subdir
----
-$dist->add_file('share/subdir/whatever/anotherfoo.txt',<< '---');
-This is anotherfoo.txt in a subdir - this shoud work on M::B 0.38
----
-$dist->add_file('other/share/bar.txt',<< '---');
-This is bar.txt
----
-$dist->regen;
-ok( -e catfile(qw/share foo.txt/), "Created 'share' directory" );
-ok( -d catfile(qw/share subdir share/), "Created 'share/subdir/share' directory" );
-ok( -d catfile(qw/share subdir whatever/), "Created 'share/subdir/whatever' directory" );
-ok( -e catfile(qw/other share bar.txt/), "Created 'other/share' directory" );
-
-# Check default when share_dir is not given
-stdout_stderr_of( sub { $mb = $dist->new_from_context });
-is( $mb->share_dir, undef,
- "Default share_dir is undef even if 'share' exists"
-);
-ok( ! exists $mb->{properties}{requires}{'File::ShareDir'},
- "File::ShareDir not added to 'requires'"
-);
-
-
-# share_dir set to scalar
-$dist->change_build_pl(
- {
- module_name => $dist->name,
- license => 'perl',
- share_dir => 'share',
- }
-);
-$dist->regen;
-stdout_stderr_of( sub { $mb = $dist->new_from_context });
-is_deeply( $mb->share_dir, { dist => [ 'share' ] },
- "Scalar share_dir set as dist-type share"
-);
-
-# share_dir set to arrayref
-$dist->change_build_pl(
- {
- module_name => $dist->name,
- license => 'perl',
- share_dir => [ 'share' ],
- }
-);
-$dist->regen;
-stdout_stderr_of( sub { $mb = $dist->new_from_context });
-is_deeply( $mb->share_dir, { dist => [ 'share' ] },
- "Arrayref share_dir set as dist-type share"
-);
-
-# share_dir set to hashref w scalar
-$dist->change_build_pl(
- {
- module_name => $dist->name,
- license => 'perl',
- share_dir => { dist => 'share' },
- }
-);
-$dist->regen;
-stdout_stderr_of( sub { $mb = $dist->new_from_context });
-is_deeply( $mb->share_dir, { dist => [ 'share' ] },
- "Hashref share_dir w/ scalar dist set as dist-type share"
-);
-
-# share_dir set to hashref w array
-$dist->change_build_pl(
- {
- module_name => $dist->name,
- license => 'perl',
- share_dir => { dist => [ 'share' ] },
- }
-);
-$dist->regen;
-stdout_stderr_of( sub { $mb = $dist->new_from_context });
-is_deeply( $mb->share_dir, { dist => [ 'share' ] },
- "Hashref share_dir w/ arrayref dist set as dist-type share"
-);
-
-# Generate a module sharedir (scalar)
-$dist->change_build_pl(
- {
- module_name => $dist->name,
- license => 'perl',
- share_dir => {
- dist => 'share',
- module => { $dist->name => 'other/share' },
- },
- }
-);
-$dist->regen;
-stdout_stderr_of( sub { $mb = $dist->new_from_context });
-is_deeply( $mb->share_dir,
- { dist => [ 'share' ],
- module => { $dist->name => ['other/share'] },
- },
- "Hashref share_dir w/ both dist and module shares (scalar-form)"
-);
-
-# Generate a module sharedir (array)
-$dist->change_build_pl(
- {
- module_name => $dist->name,
- license => 'perl',
- share_dir => {
- dist => [ 'share' ],
- module => { $dist->name => ['other/share'] },
- },
- }
-);
-$dist->regen;
-stdout_stderr_of( sub { $mb = $dist->new_from_context });
-is_deeply( $mb->share_dir,
- { dist => [ 'share' ],
- module => { $dist->name => ['other/share'] },
- },
- "Hashref share_dir w/ both dist and module shares (array-form)"
-);
-
-#--------------------------------------------------------------------------#
-# test constructing to/from mapping
-#--------------------------------------------------------------------------#
-
-is_deeply( $mb->_find_share_dir_files,
- {
- "share/foo.txt" => "dist/Simple-Share/foo.txt",
- "share/subdir/share/anotherbar.txt" => "dist/Simple-Share/subdir/share/anotherbar.txt",
- "share/subdir/whatever/anotherfoo.txt" => "dist/Simple-Share/subdir/whatever/anotherfoo.txt",
- "other/share/bar.txt" => "module/Simple-Share/bar.txt",
- },
- "share_dir filemap for copying to lib complete"
-);
-
-#--------------------------------------------------------------------------#
-# test moving files to blib
-#--------------------------------------------------------------------------#
-
-$mb->dispatch('build');
-
-ok( -d 'blib', "Build ran and blib exists" );
-ok( -d 'blib/lib/auto/share', "blib/lib/auto/share exists" );
-
-my $share_list = Module::Build->rscan_dir('blib/lib/auto/share', sub {-f});
-
-SKIP:
-{
-
-skip 'filename case not necessarily preserved', 1 if $^O eq 'VMS';
-
-is_deeply(
- [ sort @$share_list ], [
- 'blib/lib/auto/share/dist/Simple-Share/foo.txt',
- 'blib/lib/auto/share/dist/Simple-Share/subdir/share/anotherbar.txt',
- 'blib/lib/auto/share/dist/Simple-Share/subdir/whatever/anotherfoo.txt',
- 'blib/lib/auto/share/module/Simple-Share/bar.txt',
- ],
- "share_dir files copied to blib"
-);
-
-}
-
-#--------------------------------------------------------------------------#
-# test installing
-#--------------------------------------------------------------------------#
-
-my $temp_install = 'temp_install';
-mkdir $temp_install;
-ok( -d $temp_install, "temp install dir created" );
-
-$mb->install_base($temp_install);
-stdout_of( sub { $mb->dispatch('install') } );
-
-$share_list = Module::Build->rscan_dir(
- "$temp_install/lib/perl5/auto/share", sub {-f}
-);
-
-SKIP:
-{
-
-skip 'filename case not necessarily preserved', 1 if $^O eq 'VMS';
-
-is_deeply(
- [ sort @$share_list ], [
- "$temp_install/lib/perl5/auto/share/dist/Simple-Share/foo.txt",
- "$temp_install/lib/perl5/auto/share/dist/Simple-Share/subdir/share/anotherbar.txt",
- "$temp_install/lib/perl5/auto/share/dist/Simple-Share/subdir/whatever/anotherfoo.txt",
- "$temp_install/lib/perl5/auto/share/module/Simple-Share/bar.txt",
- ],
- "share_dir files correctly installed"
-);
-
-}
-
-#--------------------------------------------------------------------------#
-# test with File::ShareDir
-#--------------------------------------------------------------------------#
-
-SKIP: {
- eval { require File::ShareDir; File::ShareDir->VERSION(1.00) };
- skip "needs File::ShareDir 1.00", 2 if $@;
-
- unshift @INC, File::Spec->catdir($temp_install, qw/lib perl5/);
- require Simple::Share;
-
- eval {File::ShareDir::dist_file('Simple-Share','foo.txt') };
- is( $@, q{}, "Found shared dist file" );
-
- eval {File::ShareDir::module_file('Simple::Share','bar.txt') };
- is( $@, q{}, "Found shared module file" );
-}
+++ /dev/null
-use strict;
-use lib 't/lib';
-use MBTest;
-plan tests => 3; # or 'no_plan'
-use DistGen;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-# create dist object in a temp directory
-# enter the directory and generate the skeleton files
-my $dist = DistGen->new->chdir_in;
-$dist->add_file('mylib/MBUtil.pm', << "---");
-package MBUtil;
-sub foo { 42 }
-1;
----
-
-$dist->add_file('Build.PL', << "---");
-use strict;
-use lib 'mylib';
-use MBUtil;
-use Module::Build;
-
-die unless MBUtil::foo() == 42;
-
-my \$builder = Module::Build->new(
-module_name => '$dist->{name}',
-license => 'perl',
-);
-
-\$builder->create_build_script();
----
-
-$dist->regen;
-
-# get a Module::Build object and test with it
-my $mb = $dist->new_from_context(); # quiet by default
-isa_ok( $mb, "Module::Build" );
-is( $mb->dist_name, "Simple", "dist_name is 'Simple'" );
-ok( ( grep { /mylib/ } @INC ), "resume added \@INC addition to \@INC");
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 29;
-
-blib_load('Module::Build');
-blib_load('Module::Build::ConfigData');
-
-#########################
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new();
-$dist->change_build_pl
-({
- module_name => 'Simple',
- scripts => [ 'script' ],
- license => 'perl',
- requires => { 'File::Spec' => 0 },
-});
-
-$dist->add_file( 'MANIFEST.SKIP', <<'---' );
-^MYMETA.yml$
----
-$dist->add_file( 'script', <<'---' );
-#!perl -w
-print "Hello, World!\n";
----
-$dist->add_file( 'lib/Simple/Script.PL', <<'---' );
-#!perl -w
-
-my $filename = shift;
-open FH, "> $filename" or die "Can't create $filename: $!";
-print FH "Contents: $filename\n";
-close FH;
----
-$dist->regen;
-
-$dist->chdir_in;
-
-
-#########################
-
-my $mb = Module::Build->new_from_context;
-ok $mb;
-is $mb->license, 'perl';
-
-# Make sure cleanup files added before create_build_script() get respected
-$mb->add_to_cleanup('before_script');
-
-eval {$mb->create_build_script};
-is $@, '';
-ok -e $mb->build_script;
-
-my $dist_dir = 'Simple-0.01';
-
-# VMS in traditional mode needs the $dist_dir name to not have a '.' in it
-# as this is a directory delimiter. In extended character set mode the dot
-# is permitted for Unix format file specifications.
-if ($^O eq 'VMS') {
- my $Is_VMS_noefs = 1;
- my $vms_efs = 0;
- if (eval 'require VMS::Feature') {
- $vms_efs = VMS::Feature::current("efs_charset");
- } else {
- my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
- $vms_efs = $efs_charset =~ /^[ET1]/i;
- }
- $Is_VMS_noefs = 0 if $vms_efs;
- if ($Is_VMS_noefs) {
- $dist_dir = 'Simple-0_01';
- }
-}
-
-is $mb->dist_dir, $dist_dir;
-
-# The 'cleanup' file doesn't exist yet
-ok grep {$_ eq 'before_script'} $mb->cleanup;
-
-$mb->add_to_cleanup('save_out');
-
-# The 'cleanup' file now exists
-ok grep {$_ eq 'before_script'} $mb->cleanup;
-ok grep {$_ eq 'save_out' } $mb->cleanup;
-
-{
- # Make sure verbose=>1 works
- my $all_ok = 1;
- my $output = eval {
- stdout_of( sub { $mb->dispatch('test', verbose => 1) } )
- };
- $all_ok &&= is($@, '');
- $all_ok &&= like($output, qr/all tests successful/i);
-
- # This is the output of lib/Simple/Script.PL
- $all_ok &&= ok(-e $mb->localize_file_path('lib/Simple/Script'));
-
- unless ($all_ok) {
- # We use diag() so Test::Harness doesn't get confused.
- diag("vvvvvvvvvvvvvvvvvvvvv Simple/t/basic.t output vvvvvvvvvvvvvvvvvvvvv");
- diag($output);
- diag("^^^^^^^^^^^^^^^^^^^^^ Simple/t/basic.t output ^^^^^^^^^^^^^^^^^^^^^");
- }
-}
-
-{
- my $output = eval {
- stdout_stderr_of( sub { $mb->dispatch('disttest') } )
- };
- is $@, '';
-
- # After a test, the distdir should contain a blib/ directory
- ok -e File::Spec->catdir('Simple-0.01', 'blib');
-
- stdout_stderr_of ( sub { eval {$mb->dispatch('distdir')} } );
- is $@, '';
-
- # The 'distdir' should contain a lib/ directory
- ok -e File::Spec->catdir('Simple-0.01', 'lib');
-
- # The freshly run 'distdir' should never contain a blib/ directory, or
- # else it could get into the tarball
- ok ! -e File::Spec->catdir('Simple-0.01', 'blib');
-
- # Make sure all of the above was done by the new version of Module::Build
- open(my $fh, '<', File::Spec->catfile($dist->dirname, 'META.yml'));
- my $contents = do {local $/; <$fh>};
- $contents =~ /Module::Build version ([0-9_.]+)/m;
- cmp_ok $1, '==', $mb->VERSION, "Check version used to create META.yml: $1 == " . $mb->VERSION;
-
- SKIP: {
- skip( "Archive::Tar 1.08+ not installed", 1 )
- unless eval { require Archive::Tar && Archive::Tar->VERSION(1.08); 1 };
- $mb->add_to_cleanup($mb->dist_dir . ".tar.gz");
- eval {$mb->dispatch('dist')};
- is $@, '';
- }
-
-}
-
-{
- # Make sure the 'script' file was recognized as a script.
- my $scripts = $mb->script_files;
- ok $scripts->{script};
-
- # Check that a shebang line is rewritten
- my $blib_script = File::Spec->catfile( qw( blib script script ) );
- ok -e $blib_script;
-
- SKIP: {
- skip("We do not rewrite shebang on VMS", 1) if $^O eq 'VMS';
- open(my $fh, '<', $blib_script);
- my $first_line = <$fh>;
- isnt $first_line, "#!perl -w\n", "should rewrite the shebang line";
- }
-}
-
-
-eval {$mb->dispatch('realclean')};
-is $@, '';
-
-ok ! -e $mb->build_script;
-ok ! -e $mb->config_dir;
-ok ! -e $mb->dist_dir;
-
-SKIP: {
- skip( 'Windows-only test', 4 ) unless $^O =~ /^MSWin/;
-
- my $script_data = <<'---';
-@echo off
-echo Hello, World!
----
-
- $dist = DistGen->new();
- $dist->change_build_pl({
- module_name => 'Simple',
- scripts => [ 'bin/script.bat' ],
- license => 'perl',
- });
-
- $dist->add_file( 'bin/script.bat', $script_data );
-
- $dist->regen;
- $dist->chdir_in;
-
- $mb = Module::Build->new_from_context;
- ok $mb;
-
- eval{ $mb->dispatch('build') };
- is $@, '';
-
- my $script_file = File::Spec->catfile( qw(blib script), 'script.bat' );
- ok -f $script_file, "Native batch file copied to 'scripts'";
-
- my $out = slurp( $script_file );
- is $out, $script_data, ' unmodified by pl2bat';
-
-}
-
+++ /dev/null
-# sample.t -- a sample test file for Module::Build
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 2; # or 'no_plan'
-use DistGen;
-
-# Ensure any Module::Build modules are loaded from correct directory
-blib_load('Module::Build');
-
-# create dist object in a temp directory
-# enter the directory and generate the skeleton files
-my $dist = DistGen->new->chdir_in->regen;
-
-# get a Module::Build object and test with it
-my $mb = $dist->new_from_context(); # quiet by default
-isa_ok( $mb, "Module::Build" );
-is( $mb->dist_name, "Simple", "dist_name is 'Simple'" );
-
-# vim:ts=2:sw=2:et:sta:sts=2
+++ /dev/null
-#!/usr/bin/perl -w
-# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
-# vim:ts=8:sw=2:et:sta:sts=2
-
-use strict;
-use lib 't/lib';
-use MBTest 'no_plan';
-
-use DistGen qw(undent);
-use CPAN::Meta::YAML;
-
-blib_load('Module::Build');
-blib_load('Module::Build::ConfigData');
-
-# XXX DistGen shouldn't be assuming module-ness?
-my $dist = DistGen->new(dir => MBTest->tmpdir);
-$dist->add_file('bin/foo', undent(<<' ---'));
- #!/usr/bin/perl
-
- package bin::foo;
- $VERSION = 0.01;
-
- =head1 NAME
-
- foo - does stuff
-
- =head1 AUTHOR
-
- A. U. Thor, a.u.thor@a.galaxy.far.far.away
-
- =cut
-
- print "hello world\n";
- ---
-
-my %details = (
- dist_name => 'bin-foo',
- dist_version_from => 'bin/foo',
- dist_author => ['A. U. Thor, a.u.thor@a.galaxy.far.far.away'],
- dist_version => '0.01',
-);
-my %meta_provides = (
- 'foo' => {
- file => 'bin/foo',
- version => '0.01',
- }
-);
-$dist->change_build_pl({
- # TODO need to get all of this data out of the program itself
- ! $ENV{EXTRA_TEST} ? (
- %details, meta_merge => { provides => \%meta_provides, },
- ) : (),
- program_name => 'bin/foo',
- license => 'perl',
-});
-
-# hmm... the old assumption of what a dist looks like is wrong here
-$dist->remove_file('lib/Simple.pm'); $dist->regen;
-
-$dist->chdir_in;
-rmdir('lib');
-
-#system('konsole');
-my $mb = Module::Build->new_from_context;
-ok($mb);
-is($mb->program_name, 'bin/foo');
-is($mb->license, 'perl');
-is($mb->dist_name, 'bin-foo');
-is($mb->dist_version, '0.01');
-is_deeply($mb->dist_author,
- ['A. U. Thor, a.u.thor@a.galaxy.far.far.away']);
-my $result;
-stdout_stderr_of( sub { $result = $mb->dispatch('distmeta') } );
-ok $result;
-
-my $yml = CPAN::Meta::YAML->read_string(slurp('META.yml'))->[0];
-is_deeply($yml->{provides}, \%meta_provides);
-
-$dist->chdir_original if $dist->did_chdir;
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 3;
-use DistGen;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-my $dist = DistGen->new( dir => $tmp );
-
-$dist->add_file('t/mytest.s', <<'---' );
-#!perl
-use Test::More tests => 2;
-ok(1, 'first mytest.s');
-ok(1, 'second mytest.s');
----
-
-$dist->regen;
-$dist->chdir_in;
-
-#########################
-
-# So make sure that the test gets run with the alternate extension.
-ok my $mb = Module::Build->new(
- module_name => $dist->name,
- test_file_exts => ['.s'],
- quiet => 1,
-), 'Construct build object with test_file_exts parameter';
-
-$mb->add_to_cleanup('save_out');
-# Use uc() so we don't confuse the current test output
-my $out = uc(stdout_of(
- sub {$mb->dispatch('test', verbose => 1)}
-));
-
-like $out, qr/^OK 1 - FIRST MYTEST[.]S/m, 'Should see first test output';
-like $out, qr/^OK 2 - SECOND MYTEST[.]S/m, 'Should see second test output';
-
-# vim:ts=4:sw=4:et:sta
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use CPAN::Meta 2.110420;
-use CPAN::Meta::YAML;
-use Parse::CPAN::Meta 1.4401;
-plan tests => 4;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->change_file('Build.PL', <<"---");
-use strict;
-use Module::Build;
-
-my \$builder = Module::Build->new(
- module_name => '$dist->{name}',
- license => 'perl',
- requires => {
- 'File::Spec' => 0,
- },
- test_requires => {
- 'Test::More' => 0,
- }
-);
-
-\$builder->create_build_script();
----
-$dist->regen;
-$dist->chdir_in;
-$dist->run_build_pl;
-my $output = stdout_stderr_of sub { $dist->run_build('distmeta') };
-
-for my $file ( qw/MYMETA META/ ) {
- my $meta = Parse::CPAN::Meta->load_file($file.".json");
- is_deeply($meta->{prereqs}->{runtime},{
- requires => {
- 'File::Spec' => '0',
- }
- }, "runtime prereqs in $file");
- is_deeply($meta->{prereqs}->{test},{
- requires => {
- 'Test::More' => '0',
- }
- }, "test prereqs in $file");
-}
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-BEGIN {
- if ($^O eq 'VMS') {
- print '1..0 # Child test output confuses harness';
- exit;
- }
-}
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 7;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-
-my $dist = DistGen->new( dir => $tmp );
-
-
-$dist->add_file('t/special_ext.st', <<'---' );
-#!perl
-use Test::More tests => 2;
-ok(1, 'first test in special_ext');
-ok(1, 'second test in special_ext');
----
-
-$dist->regen;
-
-$dist->chdir_in;
-
-#########################
-
-# Here we make sure we can define an action that will test a particular type
-$::x = 0;
-my $mb = Module::Build->subclass(
- code => q#
- sub ACTION_testspecial {
- $::x++;
- shift->generic_test(type => 'special');
- }
- #
-)->new(
- module_name => $dist->name,
- test_types => { special => '.st' }
-);
-
-ok $mb;
-
-$mb->dispatch('testspecial');
-is($::x, 1, "called once");
-
-
-$mb->add_to_cleanup('save_out');
-# Use uc() so we don't confuse the current test output
-my $verbose_output = uc(stdout_of(
- sub {$mb->dispatch('testspecial', verbose => 1)}
-));
-
-like($verbose_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m);
-like($verbose_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m);
-
-is( $::x, 2, "called again");
-
-my $output = uc(stdout_of(
- sub {$mb->dispatch('testspecial', verbose => 0)}
-));
-like($output, qr/\.\. ?OK/);
-
-is($::x, 3, "called a third time");
-
-# vim:ts=4:sw=4:et:sta
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 25;
-
-blib_load('Module::Build');
-
-use DistGen;
-
-my $dist = DistGen->new()->chdir_in;
-
-$dist->add_file('t/special_ext.st', <<'---');
-#!perl
-use Test::More tests => 2;
-ok(1, 'first test in special_ext');
-ok(1, 'second test in special_ext');
----
-
-$dist->add_file('t/another_ext.at', <<'---');
-#!perl
-use Test::More tests => 2;
-ok(1, 'first test in another_ext');
-ok(1, 'second test in another_ext');
----
-$dist->add_file('t/foo.txt', <<'---');
-#!perl
-use Test::More tests => 1;
-ok 0, "don't run this non-test file";
-die "don't run this non-test file";
----
-
-$dist->regen;
-#########################
-
-my $mb = Module::Build->subclass(
- code => q#
- sub ACTION_testspecial {
- shift->generic_test(type => 'special');
- }
-
- sub ACTION_testanother {
- shift->generic_test(type => 'another');
- }
- #
- )->new(
- module_name => $dist->name,
- test_types => {
- special => '.st',
- another => '.at',
- },
- );
-
-
-ok $mb;
-
-my $special_output = uc(stdout_of(
- sub {$mb->dispatch('testspecial', verbose => 1)}
-));
-
-like($special_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m,
- 'saw expected output from first test');
-like($special_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m,
- 'saw expected output from second test');
-
-my $another_output = uc(stdout_of(
- sub {$mb->dispatch('testanother', verbose => 1)}
-));
-
-ok($another_output, 'we have some test output');
-
-like($another_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m,
- 'saw expected output from first test');
-like($another_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m,
- 'saw expected output from second test');
-
-
-my $all_output = uc(stdout_of(
- sub {$mb->dispatch('testall', verbose => 1)}
-));
-
-0 and warn "\ntestall said >>>\n$all_output\n<<<\n";
-
-like($all_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m,
- 'expected output from basic.t');
-like($all_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m,
- 'expected output from basic.t');
-
-like($all_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m);
-like($all_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m);
-
-# we get a third one from basic.t
-is(scalar(@{[$all_output =~ m/OK 1/mg]}), 3 );
-is(scalar(@{[$all_output =~ m/OK/mg]}), 8 );
-is(scalar(@{[$all_output =~ m/ALL TESTS SUCCESSFUL\./mg]}), 1);
-
-{ # once-again
-
-$dist->revert;
-
-$dist->add_file('t/foo/special.st', <<'---');
-#!perl
-use Test::More tests => 2;
-ok(1, 'first test in special_ext');
-ok(1, 'second test in special_ext');
----
-$dist->add_file('t/foo/basic_foo.t', <<'---');
-use Test::More tests => 1;
-use strict; use Simple;
-ok 1;
----
-$dist->regen;
-
-my $mb = Module::Build->subclass(
- code => q#
- sub ACTION_testspecial {
- shift->generic_test(type => 'special');
- }
-
- sub ACTION_testanother {
- shift->generic_test(type => 'another');
- }
- #
- )->new(
- recursive_test_files => 1,
- module_name => $dist->name,
- test_types => {
- special => '.st',
- another => '.at',
- },
- );
-
-ok $mb;
-
-my $special_output = uc(stdout_of(
- sub {$mb->dispatch('testspecial', verbose => 1)}
-));
-
-like($special_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m,
- 'saw expected output from first test');
-like($special_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m,
- 'saw expected output from second test');
-
-my $another_output = uc(stdout_of(
- sub {$mb->dispatch('testanother', verbose => 1)}
-));
-
-ok($another_output, 'we have some test output');
-
-like($another_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m,
- 'saw expected output from first test');
-like($another_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m,
- 'saw expected output from second test');
-
-
-my $all_output = uc(stdout_of(
- sub {$mb->dispatch('testall', verbose => 1)}
-));
-
-like($all_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m,
- 'expected output from basic.t');
-like($all_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m,
- 'expected output from basic.t');
-
-like($all_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m);
-like($all_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m);
-
-# we get a third one from basic.t
-is(scalar(@{[$all_output =~ m/(OK 1)/mg]}), 5 );
-is(scalar(@{[$all_output =~ m/(OK)/mg]}), 13 );
-
-} # end once-again
-
-# vim:ts=4:sw=4:et:sta
+++ /dev/null
-#!/usr/bin/perl -w
-
-# Test ~ expansion from command line arguments.
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 16;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-$dist->chdir_in;
-
-
-sub run_sample {
- my @args = @_;
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- $dist->clean;
-
- my $mb;
- stdout_of( sub {
- $mb = Module::Build->new_from_context( @args );
- } );
-
- return $mb;
-}
-
-
-my $p = 'install_base';
-
-SKIP: {
- my $home = $ENV{HOME} ? $ENV{HOME} : undef;
-
- if ($^O eq 'VMS') {
- # Convert the path to UNIX format, trim off the trailing slash
- $home = VMS::Filespec::unixify($home);
- $home =~ s#/$##;
- }
-
- unless (defined $home) {
- my @info = eval { getpwuid $> };
- skip "No home directory for tilde-expansion tests", 15 if $@
- or !defined $info[7];
- $home = $info[7];
- }
-
- is( run_sample( $p => '~' )->$p(), $home );
-
- is( run_sample( $p => '~/fooxzy' )->$p(), "$home/fooxzy" );
-
- is( run_sample( $p => '~/ fooxzy')->$p(), "$home/ fooxzy" );
-
- is( run_sample( $p => '~/fo o')->$p(), "$home/fo o" );
-
- is( run_sample( $p => 'fooxzy~' )->$p(), 'fooxzy~' );
-
- is( run_sample( prefix => '~' )->prefix,
- $home );
-
- # Test when HOME is different from getpwuid(), as in sudo.
- {
- local $ENV{HOME} = '/wibble/whomp';
-
- is( run_sample( $p => '~' )->$p(), "/wibble/whomp" );
- }
-
- my $mb = run_sample( install_path => { html => '~/html',
- lib => '~/lib' }
- );
- is( $mb->install_destination('lib'), "$home/lib" );
- # 'html' is translated to 'binhtml' & 'libhtml'
- is( $mb->install_destination('binhtml'), "$home/html" );
- is( $mb->install_destination('libhtml'), "$home/html" );
-
- $mb = run_sample( install_path => { lib => '~/lib' } );
- is( $mb->install_destination('lib'), "$home/lib" );
-
- $mb = run_sample( destdir => '~' );
- is( $mb->destdir, $home );
-
- $mb->$p('~');
- is( $mb->$p(), '~', 'API does not expand tildes' );
-
- skip "On OS/2 EMX all users are equal", 2 if $^O eq 'os2';
- is( run_sample( $p => '~~' )->$p(), '~~' );
- is( run_sample( $p => '~ fooxzy' )->$p(), '~ fooxzy' );
-}
-
-# Again, with named users
-SKIP: {
- my @info = eval { getpwuid $> };
- skip "No home directory for tilde-expansion tests", 1 if $@
- or !defined $info[7] or !defined $info[0];
- my ($me, $home) = @info[0,7];
-
- if ($^O eq 'VMS') {
- # Convert the path to UNIX format and trim off the trailing slash.
- # Also, the fake module we're in has mangled $ENV{HOME} for its own
- # purposes; getpwuid doesn't know about that but _detildefy does.
- $home = VMS::Filespec::unixify($ENV{HOME});
- $home =~ s#/$##;
- }
- my $expected = "$home/fooxzy";
-
- like( run_sample( $p => "~$me/fooxzy")->$p(), qr(\Q$expected\E)i );
-}
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 9;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-$dist->chdir_in;
-
-#########################
-
-
-# make sure Test::Harness loaded before we define Test::Harness::runtests otherwise we'll
-# get another redefined warning inside Test::Harness::runtests
-use Test::Harness;
-
-{
- package MB::Subclass;
- use base qw(Module::Build);
- sub harness_switches { return }
-}
-
-{
- local $SIG{__WARN__} = sub { die "Termination after a warning: $_[0]"};
- my $mock1 = { A => 1 };
- my $mock2 = { B => 2 };
-
- no warnings qw[redefine once];
-
- # This runs run_test_harness with Test::Harness::switches = undef and harness_switches() returning empty list,
- # ensure there are no warnings, and output is empty too
- {
- my $mb = MB::Subclass->new( module_name => $dist->name );
- local *Test::Harness::runtests = sub {
- is shift(), $mock1, "runtests ran with expected parameters";
- is shift(), $mock2, "runtests ran with expected parameters";
- is $Test::Harness::switches, '', "switches are undef";
- is $Test::Harness::Switches, '', "switches are undef";
- };
-
- # $Test::Harness::switches and $Test::Harness::switches are aliases, but we pretend we don't know this
- local $Test::Harness::switches = '';
- local $Test::Harness::switches = '';
- $mb->run_test_harness([$mock1, $mock2]);
-
- ok 1, "run_test_harness should not produce warning if Test::Harness::[Ss]witches are undef and harness_switches() return empty list";
- }
-
- # This runs run_test_harness with Test::Harness::switches = '' and harness_switches() returning empty list,
- # ensure there are no warnings, and switches are empty string
- {
- my $mb = MB::Subclass->new( module_name => $dist->name );
- local *Test::Harness::runtests = sub {
- is shift(), $mock1, "runtests ran with expected parameters";
- is shift(), $mock2, "runtests ran with expected parameters";
- is $Test::Harness::switches, '', "switches are empty string";
- is $Test::Harness::Switches, '', "switches are empty string";
- };
-
- # $Test::Harness::switches and $Test::Harness::switches are aliases, but we pretend we don't know this
- local $Test::Harness::switches = '';
- local $Test::Harness::switches = '';
- $mb->run_test_harness([$mock1, $mock2]);
- }
-
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use Test::More;
-use lib 't/lib';
-if (eval { require TAP::Harness && TAP::Harness->VERSION(3) }) {
- plan tests => 9;
-} else {
- plan skip_all => 'TAP::Harness 3+ not installed'
-}
-
-use MBTest;
-use DistGen;
-
-blib_load('Module::Build');
-my $tmp = MBTest->tmpdir;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-$dist->chdir_in;
-
-#########################
-
-# Make sure that TAP::Harness properly does its thing.
-$dist->change_build_pl(
- module_name => $dist->name,
- use_tap_harness => 1,
- quiet => 1,
-);
-$dist->regen;
-
-ok my $mb = $dist->new_from_context,
- 'Construct build object with test_file_exts parameter';
-
-$mb->add_to_cleanup('save_out');
-# Use uc() so we don't confuse the current test output
-my $out = uc(stdout_of(
- sub {$mb->dispatch('test', verbose => 1)}
-));
-
-like $out, qr/^OK 1/m, 'Should see first test output';
-like $out, qr/^ALL TESTS SUCCESSFUL/m, 'Should see test success message';
-
-#########################
-
-# Make sure that arguments are passed through to TAP::Harness.
-$dist->change_build_pl(
- module_name => $dist->name,
- use_tap_harness => 1,
- tap_harness_args => { verbosity => 0 },
- quiet => 1,
-);
-$dist->regen;
-
-ok $mb = $dist->new_from_context,
- 'Construct build object with test_file_exts parameter';
-
-$mb->add_to_cleanup('save_out');
-# Use uc() so we don't confuse the current test output
-$out = uc(stdout_of(
- sub {$mb->dispatch('test', verbose => 1)}
-));
-
-unlike $out, qr/^OK 1/m, 'Should not see first test output';
-like $out, qr/^ALL TESTS SUCCESSFUL/m, 'Should see test success message';
-
-#--------------------------------------------------------------------------#
-# test that a failing test dies
-#--------------------------------------------------------------------------#
-
-$dist->change_build_pl(
- module_name => $dist->name,
- use_tap_harness => 1,
- tap_harness_args => { verbosity => 1 },
- quiet => 1,
-);
-$dist->change_file('t/basic.t',<<"---");
-use Test::More tests => 1;
-use strict;
-
-use $dist->{name};
-ok 0;
----
-$dist->regen;
-
-ok $mb = $dist->new_from_context,
- 'Construct build object after setting tests to fail';
-# Use uc() so we don't confuse the current test output
-$out = stdout_stderr_of( sub { $dist->run_build('test')} );
-ok( $?, "'Build test' had non-zero exit code" );
-like( $out, qr{Errors in testing\. Cannot continue\.},
- "Saw emulated Test::Harness die() message"
-);
-
-# vim:ts=4:sw=4:et:sta
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest tests => 2;
-
-blib_load('Module::Build');
-
-my $tmp = MBTest->tmpdir;
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp );
-$dist->regen;
-
-#########################
-
-my @mod = split( /::/, $dist->name );
-my $file = File::Spec->catfile( $dist->dirname, 'lib', @mod ) . '.pm';
-is( Module::Build->version_from_file( $file ), '0.01', 'version_from_file' );
-
-ok( Module::Build->compare_versions( '1.01_01', '>', '1.01' ), 'compare: 1.0_01 > 1.0' );
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use lib 't/lib';
-use MBTest 'no_plan';
-use DistGen;
-use Cwd;
-
-blib_load('Module::Build');
-
-{
- my $cwd = Cwd::cwd;
- chdir MBTest->tmpdir();
-
- my $build = Module::Build->new(
- module_name => "Foo::Bar",
- dist_name => "Foo-Bar",
- dist_version => '1.23',
- );
-
- my $skip = "mskip.txt"; # for compatibility
- $build->_write_default_maniskip($skip);
-
- ok -r $skip, "Default maniskip written";
- my $have = slurp($skip);
-
- my $head;
- if( $build->_eumanifest_has_include ) {
- $head = "#!include_default\n";
- }
- else {
- $head = slurp($build->_default_maniskip);
- }
-
- like $have, qr/^\Q$head\E/, "default MANIFEST.SKIP used";
- like $have, qr/^# Avoid Module::Build generated /ms, "Module::Build specific entries";
- like $have, qr/Foo-Bar-/, "distribution tarball entry";
-
- DistGen::chdir_all($cwd);
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use lib 't/lib';
-use MBTest;
-use Config;
-
-my $tmp;
-
-blib_load('Module::Build');
-
-{
- my ($have_c_compiler, $tmp_exec) = check_compiler();
-
- if ( !$have_c_compiler ) {
- plan skip_all => 'No compiler found';
- } elsif ( $^O eq 'VMS' ) {
- plan skip_all => 'Child test output confuses harness';
- } elsif ( !$Config{usedl} ) {
- plan skip_all => 'Perl not compiled for dynamic loading'
- } else {
- plan tests => 22;
- }
- require Cwd;
- $tmp = MBTest->tmpdir( $tmp_exec ? () : (DIR => Cwd::cwd) );
-}
-
-
-
-#########################
-
-use DistGen;
-my $dist = DistGen->new( dir => $tmp, xs => 1 )->chdir_in->regen;
-
-my $mb = $dist->new_from_context;
-
-eval {$mb->dispatch('clean')};
-is $@, '';
-
-eval {$mb->dispatch('build')};
-is $@, '';
-
-{
- # Make sure it actually works: that we can call methods in the XS module
-
- # Unfortunately, We must do this is a subprocess because some OS will not
- # release the handle on a dynamic lib until the attaching process terminates
-
- ok $mb->run_perl_command(['-Mblib', '-M'.$dist->name, '-e1']);
-
- like stdout_of( sub {$mb->run_perl_command([
- '-Mblib', '-M'.$dist->name,
- '-we', "print @{[$dist->name]}::okay()"])}), qr/ok$/;
-
- like stdout_of( sub {$mb->run_perl_command([
- '-Mblib', '-M'.$dist->name,
- '-we', "print @{[$dist->name]}::version()"])}), qr/0.01$/;
-
- like stdout_of( sub {$mb->run_perl_command([
- '-Mblib', '-M'.$dist->name,
- '-we', "print @{[$dist->name]}::xs_version()"])}), qr/0.01$/;
-
-}
-
-{
- # Try again in a subprocess
- eval {$mb->dispatch('clean')};
- is $@, '';
-
-
- $mb->create_build_script;
- my $script = $mb->build_script;
- ok -e $script;
-
- eval {$mb->run_perl_script($script)};
- is $@, '';
-}
-
-# We can't be verbose in the sub-test, because Test::Harness will
-# think that the output is for the top-level test.
-stdout_stderr_of( sub { eval {$mb->dispatch('test')} });
-is $@, '';
-
-eval {$mb->dispatch('clean')};
-is $@, '';
-
-
-SKIP: {
- skip( "skipping a Unixish-only tests", 1 )
- unless $mb->is_unixish;
-
- $mb->{config}->push(ld => "FOO=BAR ".$mb->config('ld'));
- eval {$mb->dispatch('build')};
- is $@, '';
- $mb->{config}->pop('ld');
-}
-
-eval {$mb->dispatch('realclean')};
-is $@, '';
-
-# Make sure blib/ is gone after 'realclean'
-ok ! -e 'blib';
-
-########################################
-
-# Try a XS distro with a deep namespace
-
-
-$dist->reset( name => 'Simple::With::Deep::Name', dir => $tmp, xs => 1 );
-$dist->chdir_in->regen;
-
-$mb = $dist->new_from_context;
-
-eval { $mb->dispatch('build') };
-is $@, '';
-
-stdout_stderr_of( sub { eval { $mb->dispatch('test') } } );
-is $@, '';
-
-eval { $mb->dispatch('clean') };
-
-eval { $mb->dispatch('build', 'pureperl_only' => 1) };
-like $@, qr/\ACan\'t build xs files under --pureperl-only/, 'Can\'t build xs under pureperl';
-
-eval { $mb->dispatch('build', pureperl_only => 1, allow_pureperl => 1) };
-is $@, '', 'Can\'t build xs under pureperl, unless allow_pureperl';
-
-eval { $mb->dispatch('realclean') };
-is $@, '';
-
-########################################
-
-# Try a XS distro using a flat directory structure
-# and a 'dist_name' instead of a 'module_name'
-
-$dist->reset( name => 'Dist-Name', dir => $tmp, xs => 1 )->chdir_in;
-
-$dist->remove_file('lib/Dist-Name.pm');
-$dist->remove_file('lib/Dist-Name.xs');
-
-$dist->change_build_pl
- ({
- dist_name => 'Dist-Name',
- dist_version_from => 'Simple.pm',
- pm_files => { 'Simple.pm' => 'lib/Simple.pm' },
- xs_files => { 'Simple.xs' => 'lib/Simple.xs' },
- });
-
-$dist->add_file('Simple.xs', <<"---");
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-MODULE = Simple PACKAGE = Simple
-
-SV *
-okay()
- CODE:
- RETVAL = newSVpv( "ok", 0 );
- OUTPUT:
- RETVAL
----
-
-$dist->add_file( 'Simple.pm', <<"---" );
-package Simple;
-
-\$VERSION = '0.01';
-
-require Exporter;
-require DynaLoader;
-
-\@ISA = qw( Exporter DynaLoader );
-\@EXPORT_OK = qw( okay );
-
-bootstrap Simple \$VERSION;
-
-1;
-
-__END__
-
-=head1 NAME
-
-Simple - Perl extension for blah blah blah
-
-=head1 DESCRIPTION
-
-Stub documentation for Simple.
-
-=head1 AUTHOR
-
-A. U. Thor, a.u.thor\@a.galaxy.far.far.away
-
-=cut
----
-$dist->change_file('t/basic.t', <<"---");
-use Test::More tests => 2;
-use strict;
-
-use Simple;
-ok( 1 );
-
-ok( Simple::okay() eq 'ok' );
----
-
-$dist->regen;
-
-$mb = $dist->new_from_context;
-
-eval { $mb->dispatch('build') };
-is $@, '';
-
-stdout_of( sub { eval { $mb->dispatch('test') } } );
-is $@, '';
-
-eval { $mb->dispatch('realclean') };
-is $@, '';
-
+++ /dev/null
-package Package::Constants;
-
-use if $] >= 5.019006, 'deprecate';
-
-use strict;
-use vars qw[$VERSION $DEBUG];
-
-$VERSION = '0.04';
-$DEBUG = 0;
-
-=head1 NAME
-
-Package::Constants - List all constants declared in a package
-
-=head1 SYNOPSIS
-
- use Package::Constants;
-
- ### list the names of all constants in a given package;
- @const = Package::Constants->list( __PACKAGE__ );
- @const = Package::Constants->list( 'main' );
-
- ### enable debugging output
- $Package::Constants::DEBUG = 1;
-
-=head1 DESCRIPTION
-
-C<Package::Constants> lists all the constants defined in a certain
-package. This can be useful for, among others, setting up an
-autogenerated C<@EXPORT/@EXPORT_OK> for a Constants.pm file.
-
-=head1 CLASS METHODS
-
-=head2 @const = Package::Constants->list( PACKAGE_NAME );
-
-Lists the names of all the constants defined in the provided package.
-
-=cut
-
-sub list {
- my $class = shift;
- my $pkg = shift;
- return unless defined $pkg; # some joker might use '0' as a pkg...
-
- _debug("Inspecting package '$pkg'");
-
- my @rv;
- { no strict 'refs';
- my $stash = $pkg . '::';
-
- for my $name (sort keys %$stash ) {
-
- _debug( " Checking stash entry '$name'" );
-
- ### is it a subentry?
- my $sub = $pkg->can( $name );
- next unless defined $sub;
-
- _debug( " '$name' is a coderef" );
-
- next unless defined prototype($sub) and
- not length prototype($sub);
-
- _debug( " '$name' is a constant" );
- push @rv, $name;
- }
- }
-
- return sort @rv;
-}
-
-=head1 GLOBAL VARIABLES
-
-=head2 $Package::Constants::DEBUG
-
-When set to true, prints out debug information to STDERR about the
-package it is inspecting. Helps to identify issues when the results
-are not as you expect.
-
-Defaults to false.
-
-=cut
-
-sub _debug { warn "@_\n" if $DEBUG; }
-
-1;
-
-=head1 BUG REPORTS
-
-Please report bugs or other issues to E<lt>bug-package-constants@rt.cpan.org<gt>.
-
-=head1 AUTHOR
-
-This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
-
-=head1 COPYRIGHT
-
-This library is free software; you may redistribute and/or modify it
-under the same terms as Perl itself.
-
-=cut
-
-# Local variables:
-# c-indentation-style: bsd
-# c-basic-offset: 4
-# indent-tabs-mode: nil
-# End:
-# vim: expandtab shiftwidth=4:
+++ /dev/null
-use strict;
-use Test::More 'no_plan';
-
-BEGIN { chdir 't' if -d 't' };
-use lib '../lib';
-
-my $Class = 'Package::Constants';
-my $Func = 'list';
-my $Pkg = '_test';
-my @Good = 'A'..'C';
-my @Bad = 'D'..'E';
-
-use_ok( $Class );
-can_ok( $Class, $Func );
-
-### enable debug statements?
-$Package::Constants::DEBUG = $Package::Constants::DEBUG = @ARGV ? 1 : 0;
-
-
-### small test class
-{ package _test;
-
- ### mark us as loaded
- $INC{'_test.pm'} = $0;
-
- use vars qw[$FOO];
- $FOO = 1;
-
- ### define various subs.. the first 3 are constants,
- ### the others are not
- use constant A => 1;
- use constant B => sub { 1 };
- sub C () { 1 };
-
- sub D { 1 };
- sub E (*) { 1 };
-
-}
-
-### get the list
-{ my @list = $Class->$Func( $Pkg );
- ok( scalar(@list), "Got a list of constants" );
- is_deeply( \@list, \@Good, " Contains all expected entries" );
-}
-
-
-# Local variables:
-# c-indentation-style: bsd
-# c-basic-offset: 4
-# indent-tabs-mode: nil
-# End:
-# vim: expandtab shiftwidth=4:
# by Pod::Usage.
@ISA = qw(Pod::Select);
-$VERSION = '2.07';
+$VERSION = '2.06';
BEGIN {
if ($] < 5.006) {
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
-$VERSION = 0.9909;
+$VERSION = 0.9908;
$CLASS = 'version';
# avoid using Exporter
use vars qw($VERSION $CLASS $STRICT $LAX);
-$VERSION = 0.9909;
+$VERSION = 0.9908;
#--------------------------------------------------------------------------#
# Version regexp components
use Config;
use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
-$VERSION = 0.9909;
+$VERSION = 0.9908;
$CLASS = 'version::vpp';
require version::regex;
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok('version::vpp', 0.9909);
+ use_ok('version::vpp', 0.9908);
}
BaseTests("version::vpp","new","qv");
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok('version', 0.9909);
+ use_ok('version', 0.9908);
}
BaseTests("version","new","qv");
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok("version", 0.9909);
+ use_ok("version", 0.9908);
# If we made it this far, we are ok.
}
# Don't want to use, because we need to make sure that the import doesn't
# fire just yet (some code does this to avoid importing qv() and delare()).
require_ok("version");
-is $version::VERSION, 0.9909, "Make sure we have the correct class";
+is $version::VERSION, 0.9908, "Make sure we have the correct class";
ok(!"main"->can("qv"), "We don't have the imported qv()");
ok(!"main"->can("declare"), "We don't have the imported declare()");
}
BEGIN {
- use version 0.9909;
+ use version 0.9908;
}
pass "Didn't get caught by the wrong DIE handler, which is a good thing";
use Test::More qw/no_plan/;
BEGIN {
- use_ok('version', 0.9909);
+ use_ok('version', 0.9908);
}
my $v1 = version->new('1.2');
use Config;
BEGIN {
- use_ok('version', 0.9909);
+ use_ok('version', 0.9908);
}
SKIP: {
#########################
use Test::More tests => 3;
-use_ok("version", 0.9909);
+use_ok("version", 0.9908);
# do strict lax tests in a sub to isolate a package to test importing
SKIP: {
#########################
use strict;
-use_ok("version", 0.9909);
+use_ok("version", 0.9908);
use Test::More;
BEGIN {
for (;;)
{
const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */
- const char * const si_name =
- si_name_ix < C_ARRAY_LENGTH(si_names) ?
- si_names[si_name_ix] : "????";
+ const char * const si_name = (si_name_ix >= sizeof(si_names)) ? "????" : si_names[si_name_ix];
I32 ix;
PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n",
(IV)si_ix, si_name);
package Data::Dumper;
BEGIN {
- $VERSION = '2.151_01'; # Don't forget to set version and release
+ $VERSION = '2.151'; # Don't forget to set version and release
} # date in POD below!
#$| = 1;
$Sortkeys = 0 unless defined $Sortkeys;
$Deparse = 0 unless defined $Deparse;
$Sparseseen = 0 unless defined $Sparseseen;
-$Maxrecurse = 1000 unless defined $Maxrecurse;
#
# expects an arrayref of values to be dumped.
'bless' => $Bless, # keyword to use for "bless"
# expdepth => $Expdepth, # cutoff depth for explicit dumping
maxdepth => $Maxdepth, # depth beyond which we give up
- maxrecurse => $Maxrecurse, # depth beyond which we abort
useperl => $Useperl, # use the pure Perl implementation
sortkeys => $Sortkeys, # flag or filter for sorting hash keys
deparse => $Deparse, # use B::Deparse for coderefs
return qq['$val'];
}
- # avoid recursing infinitely [perl #122111]
- if ($s->{maxrecurse} > 0
- and $s->{level} >= $s->{maxrecurse}) {
- die "Recursion limit of $s->{maxrecurse} exceeded";
- }
-
# we have a blessed ref
my ($blesspad);
if ($realpack and !$no_bless) {
defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
}
-sub Maxrecurse {
- my($s, $v) = @_;
- defined($v) ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'};
-}
-
sub Useperl {
my($s, $v) = @_;
defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
=item *
-$Data::Dumper::Maxrecurse I<or> $I<OBJ>->Maxrecurse(I<[NEWVAL]>)
-
-Can be set to a positive integer that specifies the depth beyond which
-recursion into a structure will throw an exception. This is intended
-as a security measure to prevent perl running out of stack space when
-dumping an excessively deep structure. Can be set to 0 to remove the
-limit. Default is 1000.
-
-=item *
-
$Data::Dumper::Useperl I<or> $I<OBJ>->Useperl(I<[NEWVAL]>)
Can be set to a boolean value which controls whether the pure Perl
=head1 VERSION
-Version 2.151_01 (January 8 2015)
+Version 2.151 (March 7 2014)
=head1 SEE ALSO
SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
SV *freezer, SV *toaster,
I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
- I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq, IV maxrecurse);
+ I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq);
#ifndef HvNAME_get
#define HvNAME_get HvNAME
AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys,
- int use_sparse_seen_hash, I32 useqq, IV maxrecurse)
+ int use_sparse_seen_hash, I32 useqq)
{
char tmpbuf[128];
Size_t i;
return 1;
}
- if (maxrecurse > 0 && *levelp >= maxrecurse) {
- croak("Recursion limit of %" IVdf " exceeded", maxrecurse);
- }
-
if (realpack && !no_bless) { /* we have a blessed ref */
STRLEN blesslen;
const char * const blessstr = SvPV(bless, blesslen);
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq,
- maxrecurse);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq);
sv_catpvn(retval, ")}", 2);
} /* plain */
else {
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq,
- maxrecurse);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq);
}
SvREFCNT_dec(namesv);
}
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq,
- maxrecurse);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq);
SvREFCNT_dec(namesv);
}
else if (realtype == SVt_PVAV) {
DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash,
- useqq, maxrecurse);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq);
if (ix < ixmax)
sv_catpvn(retval, ",", 1);
}
DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
postav, levelp, indent, pad, xpad, newapad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq,
- maxrecurse);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq);
SvREFCNT_dec(sname);
Safefree(nkey_buffer);
if (indent >= 2)
seenhv, postav, &nlevel, indent, pad, xpad,
newapad, sep, pair, freezer, toaster, purity,
deepcopy, quotekeys, bless, maxdepth,
- sortkeys, use_sparse_seen_hash, useqq,
- maxrecurse);
+ sortkeys, use_sparse_seen_hash, useqq);
SvREFCNT_dec(e);
}
}
SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
SV *freezer, *toaster, *bless, *sortkeys;
I32 purity, deepcopy, quotekeys, maxdepth = 0;
- IV maxrecurse = 1000;
char tmpbuf[1024];
I32 gimme = GIMME;
int use_sparse_seen_hash = 0;
bless = *svp;
if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
maxdepth = SvIV(*svp);
- if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE)))
- maxrecurse = SvIV(*svp);
if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
sortkeys = *svp;
if (! SvTRUE(sortkeys))
DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
postav, &level, indent, pad, xpad, newapad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys,
- bless, maxdepth, sortkeys, use_sparse_seen_hash,
- useqq, maxrecurse);
+ bless, maxdepth, sortkeys, use_sparse_seen_hash, useqq);
SPAGAIN;
if (indent >= 2 && !terse)
+++ /dev/null
-#!perl
-
-# Test the Maxrecurse option
-
-use strict;
-use Test::More tests => 32;
-use Data::Dumper;
-
-SKIP: {
- skip "no XS available", 16
- if $Data::Dumper::Useperl;
- local $Data::Dumper::Useperl = 1;
- test_recursion();
-}
-
-test_recursion();
-
-sub test_recursion {
- my $pp = $Data::Dumper::Useperl ? "pure perl" : "XS";
- $Data::Dumper::Purity = 1; # make sure this has no effect
- $Data::Dumper::Indent = 0;
- $Data::Dumper::Maxrecurse = 1;
- is(eval { Dumper([]) }, '$VAR1 = [];', "$pp: maxrecurse 1, []");
- is(eval { Dumper([[]]) }, undef, "$pp: maxrecurse 1, [[]]");
- ok($@, "exception thrown");
- is(eval { Dumper({}) }, '$VAR1 = {};', "$pp: maxrecurse 1, {}");
- is(eval { Dumper({ a => 1 }) }, q($VAR1 = {'a' => 1};),
- "$pp: maxrecurse 1, { a => 1 }");
- is(eval { Dumper({ a => {} }) }, undef, "$pp: maxrecurse 1, { a => {} }");
- ok($@, "exception thrown");
- is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 1, \\1");
- is(eval { Dumper(\\1) }, undef, "$pp: maxrecurse 1, \\1");
- ok($@, "exception thrown");
- $Data::Dumper::Maxrecurse = 3;
- is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 3, \\1");
- is(eval { Dumper(\(my $s = {})) }, "\$VAR1 = \\{};", "$pp: maxrecurse 3, \\{}");
- is(eval { Dumper(\(my $s = { a => [] })) }, "\$VAR1 = \\{'a' => []};",
- "$pp: maxrecurse 3, \\{ a => [] }");
- is(eval { Dumper(\(my $s = { a => [{}] })) }, undef,
- "$pp: maxrecurse 3, \\{ a => [{}] }");
- ok($@, "exception thrown");
- $Data::Dumper::Maxrecurse = 0;
- is(eval { Dumper([[[[[]]]]]) }, q($VAR1 = [[[[[]]]]];),
- "$pp: check Maxrecurse doesn't set limit to 0 recursion");
-}
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
-our $VERSION = '5.71';
+our $VERSION = '5.70';
our (%Cache);
sub as_heavy {
common symbol names to reduce the risk of name clashes.
Generally anything not exported is still accessible from outside the
-module using the C<YourModule::item_name> (or C<< $blessed_ref->method >>)
+module using the C<YourModule::item_name> (or C<< $blessed_ref->method>>)
syntax. By convention you can use a leading underscore on names to
informally indicate that they are 'internal' and not for public use.
use Perl::OSType qw/os_type/;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
$VERSION = eval $VERSION;
# We only use this once - don't waste a symbol table entry on it.
use File::Temp qw(tempfile);
use vars qw($VERSION);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
# More details about C/C++ compilers:
# http://developers.sun.com/sunstudio/documentation/product/compiler.jsp
use ExtUtils::CBuilder::Base;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
@ISA = qw(ExtUtils::CBuilder::Base);
sub link_executable {
use ExtUtils::CBuilder::Base;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
@ISA = qw(ExtUtils::CBuilder::Base);
use File::Spec::Functions qw(catfile catdir);
use IO::File;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
@ISA = qw(ExtUtils::CBuilder::Base);
=begin comment
package ExtUtils::CBuilder::Platform::Windows::BCC;
use vars qw($VERSION);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
sub format_compiler_cmd {
my ($self, %spec) = @_;
package ExtUtils::CBuilder::Platform::Windows::GCC;
use vars qw($VERSION);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
sub format_compiler_cmd {
my ($self, %spec) = @_;
package ExtUtils::CBuilder::Platform::Windows::MSVC;
use vars qw($VERSION);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
sub arg_exec_file {
my ($self, $file) = @_;
use File::Spec;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub need_prelink { 1 }
package ExtUtils::CBuilder::Platform::android;
use strict;
-use Config;
use File::Spec;
use ExtUtils::CBuilder::Platform::Unix;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
# The Android linker will not recognize symbols from
$self->split_like_shell($args{extra_linker_flags}),
'-L' . $self->perl_inc(),
'-lperl',
- $self->split_like_shell($Config{perllibs}),
];
}
use ExtUtils::CBuilder::Platform::Unix;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
# TODO: If a specific exe_file name is requested, if the exe created
use ExtUtils::CBuilder::Platform::Unix;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub compile {
use vars qw($VERSION @ISA);
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
sub link_executable {
my $self = shift;
use ExtUtils::CBuilder::Platform::Unix;
use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+$VERSION = '0.280216';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub need_prelink { 1 }
touch_file($exporter);
$rv = $base->perl_src();
ok( -d $rv, "perl_src(): returned a directory" );
- my $rp = Cwd::realpath($subdir);
- SKIP: {
- if ($^O eq 'dec_osf' && $rp =~ m[^/cluster/members/]) {
- skip "Tru64 cluster filesystem", 1;
- } # SKIP
- is( uc($rv), uc($rp), "perl_src(): identified directory" );
- }
+ is( uc($rv), uc(Cwd::realpath($subdir)), "perl_src(): identified directory" );
is( $capture, q{}, "perl_src(): no warning, as expected" );
chdir $cwd
written in the XS language and is the core component of the Perl
extension interface.
-Before writing XS, read the L</CAVEATS> section below.
-
An B<XSUB> forms the basic unit of the XS interface. After compilation
by the B<xsubpp> compiler, each XSUB amounts to a C function definition
which will provide the glue between Perl calling conventions and C
print "time = $a\n";
print "netconf = $netconf\n";
-=head1 CAVEATS
-
-XS code has full access to system calls including C library functions.
-It thus has the capability of interfering with things that the Perl core
-or other modules have set up, such as signal handlers or file handles.
-It could mess with the memory, or any number of harmful things. Don't.
-
-Some modules have an event loop, waiting for user-input. It is highly
-unlikely that two such modules would work adequately together in a
-single Perl application.
-
-In general, the perl interpreter views itself as the center of the
-universe as far as the Perl program goes. XS code is viewed as a
-help-mate, to accomplish things that perl doesn't do, or doesn't do fast
-enough, but always subservient to perl. The closer XS code adheres to
-this model, the less likely conflicts will occur.
-
-One area where there has been conflict is in regards to C locales. (See
-L<perllocale>.) perl, with one exception and unless told otherwise,
-sets up the underlying locale the program is running in to that passed
-into it from the environment. As of v5.20, this underlying locale is
-completely hidden from pure perl code outside the lexical scope of
-C<S<use locale>>; except a couple of function calls in the POSIX
-module of necessity use it. But the underlying locale, with that one
-exception is exposed to XS code, affecting all C library routines whose
-behavior is locale-dependent. The exception is the
-L<C<LC_NUMERIC>|perllocale/Category LC_NUMERIC: Numeric Formatting>
-locale category, and the reason it is an exception is that experience
-has shown that it can be problematic for XS code, whereas we have not
-had reports of problems with the
-L<other locale categories|perllocale/WHAT IS A LOCALE>. And the reason
-for this one category being problematic is that the character used as a
-decimal point can vary. Many European languages use a comma, whereas
-English, and hence Perl are expecting a dot (U+002E: FULL STOP). Many
-modules can handle only the radix character being a dot, and so perl
-attempts to make it so. Up through Perl v5.20, the attempt was merely
-to set C<LC_NUMERIC> upon startup to the C<"C"> locale. Any
-L<setlocale()|perllocale/The setlocale function> otherwise would change
-it; this caused some failures. Therefore, starting in v5.22, perl tries
-to keep C<LC_NUMERIC> always set to C<"C"> for XS code.
-
-To summarize, here's what to expect and how to handle locales in XS code:
-
-=over
-
-=item Non-locale-aware XS code
-
-Keep in mind that even if you think your code is not locale-aware, it
-may call a C library function that is. Hopefully the man page for such
-a function will indicate that dependency, but the documentation is
-imperfect.
-
-The current locale is exposed to XS code except possibly C<LC_NUMERIC>.
-There have not been reports of problems with these other categories.
-
-Up through v5.20, Perl initializes things on start-up so that
-C<LC_NUMERIC> is set to the "C" locale. But if any code anywhere
-changes it, it will stay changed. This means that your module can't
-count on C<LC_NUMERIC> being something in particular, and you can't
-expect floating point numbers (including version strings) to have dots
-in them. If you don't allow for a non-dot, your code could break if
-anyone anywhere changes the locale. For this reason, v5.22 is changing
-the behavior so that Perl tries to keep C<LC_NUMERIC> in the "C" locale
-except around the operations internally where it should be something
-else. Misbehaving XS code will always be able to change the locale
-anyway, but the most common instance of this is checked for and
-handled.
-
-=item Locale-aware XS code
-
-If the locale from the user's environment is desired, there should be no
-need for XS code to set the locale except for C<LC_NUMERIC>, as perl has
-already set it up. XS code should avoid changing the locale, as it can
-adversely affect other, unrelated, code and may not be thread safe.
-However, some alien libraries that may be called do set it, such as
-C<Gtk>. This can cause problems for the perl core and other modules.
-Starting in v5.20.1, calling the function
-L<sync_locale()|perlapi/sync_locale> from XS should be sufficient to
-avoid most of these problems. Prior to this, you need a pure Perl
-segment that does this:
-
- POSIX::setlocale(LC_ALL, POSIX::setlocale(LC_ALL));
-
-Macros are provided for XS code to temporarily change to use the
-underlying C<LC_NUMERIC> locale when necessary. An API is being
-developed for this, but has not yet been nailed down, but will be during
-the course of v5.21. Send email to L<mailto:perl5-porters@perl.org> for
-guidance.
-
-=back
=head1 XS VERSION
@ISA = qw(IO::Handle);
-$VERSION = "1.38";
+$VERSION = "1.37";
@EXPORT_OK = qw(sockatmark);
=item connected
-If the socket is in a connected state, the peer address is returned. If the
-socket is not in a connected state, undef is returned.
-
-Note that connected() considers a half-open TCP socket to be "in a connected
-state". Specifically, connected() does not distinguish between the
-B<ESTABLISHED> and B<CLOSE-WAIT> TCP states; it returns the peer address,
-rather than undef, in either case. Thus, in general, connected() cannot
-be used to reliably learn whether the peer has initiated a graceful shutdown
-because in most cases (see below) the local TCP state machine remains in
-B<CLOSE-WAIT> until the local application calls shutdown() or close();
-only at that point does connected() return undef.
-
-The "in most cases" hedge is because local TCP state machine behavior may
-depend on the peer's socket options. In particular, if the peer socket has
-SO_LINGER enabled with a zero timeout, then the peer's close() will generate
-a RST segment, upon receipt of which the local TCP transitions immediately to
-B<CLOSED>, and in that state, connected() I<will> return undef.
+If the socket is in a connected state the peer address is returned.
+If the socket is not in a connected state then undef will be returned.
=item protocol
{ # [perl #64772] IO::Handle->sync fails on an O_RDONLY descriptor
$Config{d_fsync}
or skip "No fsync", 1;
- $^O =~ /^(?:aix|irix)$/
- and skip "fsync() documented to fail on non-writable handles on $^O", 1;
+ $^O eq 'aix'
+ and skip "fsync() documented to fail on non-writable handles on AIX", 1;
$^O eq 'cygwin'
and skip "fsync() on cygwin uses FlushFileBuffers which requires a writable handle", 1;
open my $fh, "<", "t/io_xs.t"
But failure_handler_auto, instead of dying or anything, compiles
$key, caching it in
- $lh->{'failure_lex'}{$key} = $compiled
+ $lh->{'failure_lex'}{$key} = $complied
and then calls the compiled value, and returns that. (I.e., if
$key looks like bracket notation, $compiled is a sub, and we return
about, even if some of their answers are sometimes wonky,
particularly where they start talking about pluralization.
-The Locale/Maketext.pm source. Observe that the module is much
+The Locale/Maketext.pm source. Obverse that the module is much
shorter than its documentation!
=head1 COPYRIGHT AND DISCLAIMER
-5.20150912
- - Updated for v5.20.3
-
-5.20150820
- - Updated for v5.23.2
-
-5.20150720
- - Updated for v5.23.1
-
-5.20150520
- - Updated for v5.22.0
-
-5.20150420
- - Updated for v5.21.11
- - fixes a fencepost error in is_core()
- - copes with versions that do not match x.yyyzzz
-
-5.20150320
- - Updated for v5.21.10
-
-5.20150220
- - Updated for v5.21.9
-
-5.20150214
- - Updated for v5.20.2
-
-5.20150120
- - Updated for v5.21.8
-
-5.20141220
- - Updated for v5.21.7
-
-5.20141120
- - Updated for v5.21.6
-
-5.20141020
- - Updated for v5.21.5
-
-5.20141002
- - Updated for v5.18.3 and v5.18.4
-
-5.20140920
- - Updated for v5.21.4
-
-5.20140914
- - Updated for v5.20.1
-
-5.021003
- - Prepared for v5.21.3
-
-5.021002
- - Prepared for v5.21.2
-
-5.021001_01
- - Prepared for v5.21.1
-
3.11
- Prepared for v5.20.0
- Fix regression in corelist with -v output listing the same perl
3.06 Thu Feb 20 2014
- updated for 5.19.9
- fix Module::CoreList::is_core default perl version
- - fix Module::CoreList::is_core version comparison
+ - fix Module::CoreList::is_core version comparision
3.05
- Prepared for v5.19.9
%bug_tracker %deprecated %delta/;
use Module::CoreList::TieHashDelta;
use version;
-$VERSION = '5.20150822';
-
-sub _released_order { # Sort helper, to make '?' sort after everything else
- (substr($released{$a}, 0, 1) eq "?")
- ? ((substr($released{$b}, 0, 1) eq "?")
- ? 0
- : 1)
- : ((substr($released{$b}, 0, 1) eq "?")
- ? -1
- : $released{$a} cmp $released{$b} )
-}
+$VERSION = '5.021001';
my $dumpinc = 0;
sub import {
my $version = shift;
my @perls = $version
- ? grep { defined $version{$_}{ $module } &&
+ ? grep { exists $version{$_}{ $module } &&
$version{$_}{ $module } ge $version } keys %version
: grep { exists $version{$_}{ $module } } keys %version;
sub first_release_by_date {
my @perls = &first_release_raw;
return unless @perls;
- return (sort _released_order @perls)[0];
+ return (sort { $released{$a} cmp $released{$b} } @perls)[0];
}
sub first_release {
sub find_version {
my $v = shift;
- if ($v->isa(__PACKAGE__)) {
- $v = shift;
- return if not defined $v;
- }
+ $v = shift if eval { $v->isa(__PACKAGE__) };
return $version{$v} if defined $version{$v};
- return;
+ return undef;
}
sub is_deprecated {
}
sub removed_from_by_date {
- my @perls = sort _released_order &removed_raw;
+ my @perls = sort { $released{$a} cmp $released{$b} } &removed_raw;
return shift @perls;
}
5.019006 => '2013-11-20',
5.019007 => '2013-12-20',
5.018002 => '2014-01-06',
- 5.018003 => '2014-10-01',
- 5.018004 => '2014-10-01',
5.019008 => '2014-01-20',
5.019009 => '2014-02-20',
5.01901 => '2014-03-20',
5.019011 => '2014-04-20',
5.020000 => '2014-05-27',
5.021000 => '2014-05-27',
- 5.021001 => '2014-06-20',
- 5.021002 => '2014-07-20',
- 5.021003 => '2014-08-20',
- 5.020001 => '2014-09-14',
- 5.021004 => '2014-09-20',
- 5.021005 => '2014-10-20',
- 5.021006 => '2014-11-20',
- 5.021007 => '2014-12-20',
- 5.021008 => '2015-01-20',
- 5.020002 => '2015-02-14',
- 5.021009 => '2015-02-21',
- 5.021010 => '2015-03-20',
- 5.021011 => '2015-04-20',
- 5.022000 => '2015-06-01',
- 5.023000 => '2015-06-20',
- 5.023001 => '2015-07-20',
- 5.023002 => '2015-08-20',
- 5.020003 => '2015-09-12',
);
for my $version ( sort { $a <=> $b } keys %released ) {
'Config' => undef,
'DB_File' => '1.03',
'ExtUtils::Embed' => '1.18',
- 'ExtUtils::Install' => '1.15',
- 'ExtUtils::Liblist' => '1.20',
- 'ExtUtils::MM_Unix' => '1.107',
+ 'ExtUtils::Install' => '1.15 ',
+ 'ExtUtils::Liblist' => '1.20 ',
+ 'ExtUtils::MM_Unix' => '1.107 ',
'ExtUtils::MakeMaker' => '5.38',
'ExtUtils::Manifest' => '1.27',
- 'ExtUtils::Mkbootstrap' => '1.13',
- 'ExtUtils::Mksymlists' => '1.12',
- 'ExtUtils::testlib' => '1.11',
+ 'ExtUtils::Mkbootstrap' => '1.13 ',
+ 'ExtUtils::Mksymlists' => '1.12 ',
+ 'ExtUtils::testlib' => '1.11 ',
'Fatal' => undef,
'File::Basename' => '2.4',
'FindBin' => '1.04',
'CGI::Push' => '1.00',
'CGI::Switch' => '0.05',
'CPAN' => '1.2401',
- 'CPAN::FirstTime' => '1.18',
+ 'CPAN::FirstTime' => '1.18 ',
'CPAN::Nox' => undef,
'Class::Struct' => undef,
'Cwd' => '2.00',
'DynaLoader' => '1.02',
'ExtUtils::Command' => '1.00',
'ExtUtils::Embed' => '1.2501',
- 'ExtUtils::Install' => '1.16',
- 'ExtUtils::Liblist' => '1.2201',
- 'ExtUtils::MM_Unix' => '1.114',
+ 'ExtUtils::Install' => '1.16 ',
+ 'ExtUtils::Liblist' => '1.2201 ',
+ 'ExtUtils::MM_Unix' => '1.114 ',
'ExtUtils::MM_Win32' => undef,
'ExtUtils::MakeMaker' => '5.4002',
- 'ExtUtils::Manifest' => '1.33',
- 'ExtUtils::Mksymlists' => '1.13',
+ 'ExtUtils::Manifest' => '1.33 ',
+ 'ExtUtils::Mksymlists' => '1.13 ',
'ExtUtils::XSSymSet' => '1.0',
'Fcntl' => '1.03',
'File::Basename' => '2.5',
'CGI::Push' => '1.01',
'CGI::Switch' => '0.06',
'CPAN' => '1.40',
- 'CPAN::FirstTime' => '1.30',
+ 'CPAN::FirstTime' => '1.30 ',
'Cwd' => '2.01',
'DB_File' => '1.15',
'DynaLoader' => '1.03',
'ExtUtils::Command' => '1.01',
'ExtUtils::Embed' => '1.2505',
- 'ExtUtils::Install' => '1.28',
- 'ExtUtils::Liblist' => '1.25',
- 'ExtUtils::MM_Unix' => '1.118',
+ 'ExtUtils::Install' => '1.28 ',
+ 'ExtUtils::Liblist' => '1.25 ',
+ 'ExtUtils::MM_Unix' => '1.118 ',
'ExtUtils::MakeMaker' => '5.42',
- 'ExtUtils::Mkbootstrap' => '1.14',
- 'ExtUtils::Mksymlists' => '1.16',
+ 'ExtUtils::Mkbootstrap' => '1.14 ',
+ 'ExtUtils::Mksymlists' => '1.16 ',
'File::Basename' => '2.6',
'File::DosGlob' => undef,
'File::Path' => '1.0402',
'B::Xref' => undef,
'CGI::Carp' => '1.101',
'CPAN' => '1.3901',
- 'CPAN::FirstTime' => '1.29',
+ 'CPAN::FirstTime' => '1.29 ',
'DB_File' => '1.60',
'Data::Dumper' => '2.09',
'Errno' => '1.09',
'ExtUtils::Installed' => '0.02',
- 'ExtUtils::MM_Unix' => '1.12601',
+ 'ExtUtils::MM_Unix' => '1.12601 ',
'ExtUtils::MakeMaker' => '5.4301',
- 'ExtUtils::Mkbootstrap' => '1.13',
- 'ExtUtils::Mksymlists' => '1.17',
+ 'ExtUtils::Mkbootstrap' => '1.13 ',
+ 'ExtUtils::Mksymlists' => '1.17 ',
'ExtUtils::Packlist' => '0.03',
'Fatal' => '1.02',
'File::Path' => '1.0401',
5.00504 => {
delta_from => 5.00503,
changed => {
- 'CPAN::FirstTime' => '1.36',
+ 'CPAN::FirstTime' => '1.36 ',
'DB_File' => '1.807',
- 'ExtUtils::Install' => '1.28',
- 'ExtUtils::Liblist' => '1.25',
- 'ExtUtils::MM_Unix' => '1.12602',
- 'ExtUtils::Manifest' => '1.33',
+ 'ExtUtils::Install' => '1.28 ',
+ 'ExtUtils::Liblist' => '1.25 ',
+ 'ExtUtils::MM_Unix' => '1.12602 ',
+ 'ExtUtils::Manifest' => '1.33 ',
'ExtUtils::Miniperl' => undef,
- 'ExtUtils::Mkbootstrap' => '1.14',
- 'ExtUtils::Mksymlists' => '1.17',
- 'ExtUtils::testlib' => '1.11',
+ 'ExtUtils::Mkbootstrap' => '1.14 ',
+ 'ExtUtils::Mksymlists' => '1.17 ',
+ 'ExtUtils::testlib' => '1.11 ',
'File::Compare' => '1.1002',
'File::Spec' => '0.8',
'File::Spec::Functions' => undef,
'CGI::Pretty' => '1.03',
'CGI::Switch' => undef,
'CPAN' => '1.52',
- 'CPAN::FirstTime' => '1.38',
+ 'CPAN::FirstTime' => '1.38 ',
'Carp::Heavy' => undef,
'Class::Struct' => '0.58',
'Cwd' => '2.02',
'Exporter' => '5.562',
'Exporter::Heavy' => undef,
'ExtUtils::MM_Cygwin' => undef,
- 'ExtUtils::MM_Unix' => '1.12603',
+ 'ExtUtils::MM_Unix' => '1.12603 ',
'ExtUtils::MakeMaker' => '5.45',
'File::Copy' => '2.03',
'File::Glob' => '0.991',
5.006002 => {
delta_from => 5.006001,
changed => {
- 'CPAN::FirstTime' => '1.53',
+ 'CPAN::FirstTime' => '1.53 ',
'DB_File' => '1.806',
'Data::Dumper' => '2.121',
'ExtUtils::Command' => '1.05',
'CGI::Switch' => '1.00',
'CGI::Util' => '1.3',
'CPAN' => '1.59_56',
- 'CPAN::FirstTime' => '1.54',
+ 'CPAN::FirstTime' => '1.54 ',
'CPAN::Nox' => '1.00_01',
'Carp' => '1.01',
'Carp::Heavy' => '1.01',
'CGI' => '2.81',
'CGI::Carp' => '1.23',
'CPAN' => '1.61',
- 'CPAN::FirstTime' => '1.56',
+ 'CPAN::FirstTime' => '1.56 ',
'CPAN::Nox' => '1.02',
'Digest::MD5' => '2.20',
'Dumpvalue' => '1.11',
'CGI::Pretty' => '1.07_00',
'CGI::Util' => '1.31',
'CPAN' => '1.76_01',
- 'CPAN::FirstTime' => '1.60',
+ 'CPAN::FirstTime' => '1.60 ',
'CPAN::Nox' => '1.03',
'Class::Struct' => '0.63',
'Cwd' => '2.08',
'Module::CoreList::Utils'=> '3.03',
},
},
- 5.018003 => {
- delta_from => 5.018002,
- changed => {
- 'Module::CoreList' => '3.12',
- 'Module::CoreList::TieHashDelta'=> '3.12',
- 'Module::CoreList::Utils'=> '3.12',
- },
- },
- 5.018004 => {
- delta_from => 5.018003,
- changed => {
- 'Module::CoreList' => '3.13',
- 'Module::CoreList::TieHashDelta'=> '3.13',
- 'Module::CoreList::Utils'=> '3.13',
- },
- },
5.019000 => {
delta_from => 5.018000,
changed => {
'inc::latest' => 1,
}
},
- 5.021001 => {
- delta_from => 5.021000,
- changed => {
- 'App::Prove' => '3.32',
- 'App::Prove::State' => '3.32',
- 'App::Prove::State::Result'=> '3.32',
- 'App::Prove::State::Result::Test'=> '3.32',
- 'Archive::Tar' => '2.00',
- 'Archive::Tar::Constant'=> '2.00',
- 'Archive::Tar::File' => '2.00',
- 'B' => '1.49',
- 'B::Deparse' => '1.27',
- 'Benchmark' => '1.19',
- 'CPAN::Meta' => '2.141520',
- 'CPAN::Meta::Converter' => '2.141520',
- 'CPAN::Meta::Feature' => '2.141520',
- 'CPAN::Meta::History' => '2.141520',
- 'CPAN::Meta::Prereqs' => '2.141520',
- 'CPAN::Meta::Spec' => '2.141520',
- 'CPAN::Meta::Validator' => '2.141520',
- 'Carp' => '1.34',
- 'Carp::Heavy' => '1.34',
- 'Config' => '5.021001',
- 'Cwd' => '3.48',
- 'Data::Dumper' => '2.152',
- 'Devel::PPPort' => '3.24',
- 'Devel::Peek' => '1.17',
- 'Digest::SHA' => '5.92',
- 'DynaLoader' => '1.26',
- 'Encode' => '2.62',
- 'Errno' => '1.20_04',
- 'Exporter' => '5.71',
- 'Exporter::Heavy' => '5.71',
- 'ExtUtils::Install' => '1.68',
- 'ExtUtils::Miniperl' => '1.02',
- 'ExtUtils::ParseXS' => '3.25',
- 'ExtUtils::ParseXS::Constants'=> '3.25',
- 'ExtUtils::ParseXS::CountLines'=> '3.25',
- 'ExtUtils::ParseXS::Eval'=> '3.25',
- 'ExtUtils::ParseXS::Utilities'=> '3.25',
- 'ExtUtils::Typemaps' => '3.25',
- 'ExtUtils::Typemaps::Cmd'=> '3.25',
- 'ExtUtils::Typemaps::InputMap'=> '3.25',
- 'ExtUtils::Typemaps::OutputMap'=> '3.25',
- 'ExtUtils::Typemaps::Type'=> '3.25',
- 'Fatal' => '2.25',
- 'File::Spec' => '3.48',
- 'File::Spec::Cygwin' => '3.48',
- 'File::Spec::Epoc' => '3.48',
- 'File::Spec::Functions' => '3.48',
- 'File::Spec::Mac' => '3.48',
- 'File::Spec::OS2' => '3.48',
- 'File::Spec::Unix' => '3.48',
- 'File::Spec::VMS' => '3.48',
- 'File::Spec::Win32' => '3.48',
- 'Hash::Util' => '0.17',
- 'IO' => '1.32',
- 'List::Util' => '1.39',
- 'List::Util::XS' => '1.39',
- 'Locale::Codes' => '3.31',
- 'Locale::Codes::Constants'=> '3.31',
- 'Locale::Codes::Country'=> '3.31',
- 'Locale::Codes::Country_Codes'=> '3.31',
- 'Locale::Codes::Country_Retired'=> '3.31',
- 'Locale::Codes::Currency'=> '3.31',
- 'Locale::Codes::Currency_Codes'=> '3.31',
- 'Locale::Codes::Currency_Retired'=> '3.31',
- 'Locale::Codes::LangExt'=> '3.31',
- 'Locale::Codes::LangExt_Codes'=> '3.31',
- 'Locale::Codes::LangExt_Retired'=> '3.31',
- 'Locale::Codes::LangFam'=> '3.31',
- 'Locale::Codes::LangFam_Codes'=> '3.31',
- 'Locale::Codes::LangFam_Retired'=> '3.31',
- 'Locale::Codes::LangVar'=> '3.31',
- 'Locale::Codes::LangVar_Codes'=> '3.31',
- 'Locale::Codes::LangVar_Retired'=> '3.31',
- 'Locale::Codes::Language'=> '3.31',
- 'Locale::Codes::Language_Codes'=> '3.31',
- 'Locale::Codes::Language_Retired'=> '3.31',
- 'Locale::Codes::Script' => '3.31',
- 'Locale::Codes::Script_Codes'=> '3.31',
- 'Locale::Codes::Script_Retired'=> '3.31',
- 'Locale::Country' => '3.31',
- 'Locale::Currency' => '3.31',
- 'Locale::Language' => '3.31',
- 'Locale::Script' => '3.31',
- 'Math::BigFloat' => '1.9994',
- 'Math::BigInt' => '1.9995',
- 'Math::BigInt::Calc' => '1.9994',
- 'Math::BigInt::CalcEmu' => '1.9994',
- 'Math::BigRat' => '0.2608',
- 'Module::CoreList' => '5.021001_01',
- 'Module::CoreList::TieHashDelta'=> '5.021001_01',
- 'Module::CoreList::Utils'=> '5.021001_01',
- 'Module::Metadata' => '1.000024',
- 'Module::Metadata::corpus::BOMTest::UTF16BE'=> undef,
- 'Module::Metadata::corpus::BOMTest::UTF16LE'=> undef,
- 'Module::Metadata::corpus::BOMTest::UTF8'=> '1',
- 'NDBM_File' => '1.13',
- 'Net::Config' => '1.14',
- 'Net::SMTP' => '2.34',
- 'Net::Time' => '2.11',
- 'OS2::Process' => '1.10',
- 'POSIX' => '1.40',
- 'PerlIO::encoding' => '0.19',
- 'PerlIO::mmap' => '0.013',
- 'PerlIO::scalar' => '0.19',
- 'PerlIO::via' => '0.15',
- 'Pod::Html' => '1.22',
- 'Scalar::Util' => '1.39',
- 'SelfLoader' => '1.22',
- 'Socket' => '2.014',
- 'Storable' => '2.51',
- 'TAP::Base' => '3.32',
- 'TAP::Formatter::Base' => '3.32',
- 'TAP::Formatter::Color' => '3.32',
- 'TAP::Formatter::Console'=> '3.32',
- 'TAP::Formatter::Console::ParallelSession'=> '3.32',
- 'TAP::Formatter::Console::Session'=> '3.32',
- 'TAP::Formatter::File' => '3.32',
- 'TAP::Formatter::File::Session'=> '3.32',
- 'TAP::Formatter::Session'=> '3.32',
- 'TAP::Harness' => '3.32',
- 'TAP::Harness::Env' => '3.32',
- 'TAP::Object' => '3.32',
- 'TAP::Parser' => '3.32',
- 'TAP::Parser::Aggregator'=> '3.32',
- 'TAP::Parser::Grammar' => '3.32',
- 'TAP::Parser::Iterator' => '3.32',
- 'TAP::Parser::Iterator::Array'=> '3.32',
- 'TAP::Parser::Iterator::Process'=> '3.32',
- 'TAP::Parser::Iterator::Stream'=> '3.32',
- 'TAP::Parser::IteratorFactory'=> '3.32',
- 'TAP::Parser::Multiplexer'=> '3.32',
- 'TAP::Parser::Result' => '3.32',
- 'TAP::Parser::Result::Bailout'=> '3.32',
- 'TAP::Parser::Result::Comment'=> '3.32',
- 'TAP::Parser::Result::Plan'=> '3.32',
- 'TAP::Parser::Result::Pragma'=> '3.32',
- 'TAP::Parser::Result::Test'=> '3.32',
- 'TAP::Parser::Result::Unknown'=> '3.32',
- 'TAP::Parser::Result::Version'=> '3.32',
- 'TAP::Parser::Result::YAML'=> '3.32',
- 'TAP::Parser::ResultFactory'=> '3.32',
- 'TAP::Parser::Scheduler'=> '3.32',
- 'TAP::Parser::Scheduler::Job'=> '3.32',
- 'TAP::Parser::Scheduler::Spinner'=> '3.32',
- 'TAP::Parser::Source' => '3.32',
- 'TAP::Parser::SourceHandler'=> '3.32',
- 'TAP::Parser::SourceHandler::Executable'=> '3.32',
- 'TAP::Parser::SourceHandler::File'=> '3.32',
- 'TAP::Parser::SourceHandler::Handle'=> '3.32',
- 'TAP::Parser::SourceHandler::Perl'=> '3.32',
- 'TAP::Parser::SourceHandler::RawTAP'=> '3.32',
- 'TAP::Parser::YAMLish::Reader'=> '3.32',
- 'TAP::Parser::YAMLish::Writer'=> '3.32',
- 'Term::ANSIColor' => '4.03',
- 'Test::Builder' => '1.001003',
- 'Test::Builder::Module' => '1.001003',
- 'Test::Builder::Tester' => '1.23_003',
- 'Test::Harness' => '3.32',
- 'Test::More' => '1.001003',
- 'Test::Simple' => '1.001003',
- 'Tie::File' => '1.01',
- 'Unicode' => '7.0.0',
- 'Unicode::Collate' => '1.07',
- 'Unicode::Normalize' => '1.18',
- 'Unicode::UCD' => '0.58',
- 'XS::APItest' => '0.61',
- '_charnames' => '1.41',
- 'autodie' => '2.25',
- 'autodie::Scope::Guard' => '2.25',
- 'autodie::Scope::GuardStack'=> '2.25',
- 'autodie::ScopeUtil' => '2.25',
- 'autodie::exception' => '2.25',
- 'autodie::exception::system'=> '2.25',
- 'autodie::hints' => '2.25',
- 'autodie::skip' => '2.25',
- 'charnames' => '1.41',
- 'locale' => '1.04',
- 'threads' => '1.94',
- 'utf8' => '1.14',
- 'warnings' => '1.24',
- },
- removed => {
- }
- },
- 5.021002 => {
- delta_from => 5.021001,
- changed => {
- 'B' => '1.50',
- 'Config' => '5.021002',
- 'Cwd' => '3.49',
- 'Devel::Peek' => '1.18',
- 'ExtUtils::Manifest' => '1.64',
- 'File::Copy' => '2.30',
- 'File::Spec' => '3.49',
- 'File::Spec::Cygwin' => '3.49',
- 'File::Spec::Epoc' => '3.49',
- 'File::Spec::Functions' => '3.49',
- 'File::Spec::Mac' => '3.49',
- 'File::Spec::OS2' => '3.49',
- 'File::Spec::Unix' => '3.49',
- 'File::Spec::VMS' => '3.49',
- 'File::Spec::Win32' => '3.49',
- 'Filter::Simple' => '0.92',
- 'Hash::Util' => '0.18',
- 'IO' => '1.33',
- 'IO::Socket::IP' => '0.31',
- 'IPC::Open3' => '1.17',
- 'Math::BigFloat' => '1.9996',
- 'Math::BigInt' => '1.9996',
- 'Math::BigInt::Calc' => '1.9996',
- 'Math::BigInt::CalcEmu' => '1.9996',
- 'Module::CoreList' => '5.021002',
- 'Module::CoreList::TieHashDelta'=> '5.021002',
- 'Module::CoreList::Utils'=> '5.021002',
- 'POSIX' => '1.41',
- 'Pod::Usage' => '1.64',
- 'XS::APItest' => '0.62',
- 'arybase' => '0.08',
- 'experimental' => '0.008',
- 'threads' => '1.95',
- 'warnings' => '1.26',
- },
- removed => {
- }
- },
- 5.021003 => {
- delta_from => 5.021002,
- changed => {
- 'B::Debug' => '1.21',
- 'CPAN::Meta' => '2.142060',
- 'CPAN::Meta::Converter' => '2.142060',
- 'CPAN::Meta::Feature' => '2.142060',
- 'CPAN::Meta::History' => '2.142060',
- 'CPAN::Meta::Merge' => '2.142060',
- 'CPAN::Meta::Prereqs' => '2.142060',
- 'CPAN::Meta::Requirements'=> '2.126',
- 'CPAN::Meta::Spec' => '2.142060',
- 'CPAN::Meta::Validator' => '2.142060',
- 'Config' => '5.021003',
- 'Config::Perl::V' => '0.22',
- 'ExtUtils::CBuilder' => '0.280217',
- 'ExtUtils::CBuilder::Base'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Unix'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::VMS'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Windows'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::aix'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::android'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::darwin'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::os2'=> '0.280217',
- 'ExtUtils::Manifest' => '1.65',
- 'HTTP::Tiny' => '0.047',
- 'IPC::Open3' => '1.18',
- 'Module::CoreList' => '5.021003',
- 'Module::CoreList::TieHashDelta'=> '5.021003',
- 'Module::CoreList::Utils'=> '5.021003',
- 'Opcode' => '1.28',
- 'POSIX' => '1.42',
- 'Safe' => '2.38',
- 'Socket' => '2.015',
- 'Sys::Hostname' => '1.19',
- 'UNIVERSAL' => '1.12',
- 'XS::APItest' => '0.63',
- 'perlfaq' => '5.0150045',
- },
- removed => {
- }
- },
- 5.020001 => {
- delta_from => 5.020000,
- changed => {
- 'Config' => '5.020001',
- 'Config::Perl::V' => '0.22',
- 'Cwd' => '3.48',
- 'Exporter' => '5.71',
- 'Exporter::Heavy' => '5.71',
- 'ExtUtils::CBuilder' => '0.280217',
- 'ExtUtils::CBuilder::Base'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Unix'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::VMS'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Windows'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::aix'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::android'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::darwin'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280217',
- 'ExtUtils::CBuilder::Platform::os2'=> '0.280217',
- 'File::Copy' => '2.30',
- 'File::Spec' => '3.48',
- 'File::Spec::Cygwin' => '3.48',
- 'File::Spec::Epoc' => '3.48',
- 'File::Spec::Functions' => '3.48',
- 'File::Spec::Mac' => '3.48',
- 'File::Spec::OS2' => '3.48',
- 'File::Spec::Unix' => '3.48',
- 'File::Spec::VMS' => '3.48',
- 'File::Spec::Win32' => '3.48',
- 'Module::CoreList' => '5.020001',
- 'Module::CoreList::TieHashDelta'=> '5.020001',
- 'Module::CoreList::Utils'=> '5.020001',
- 'PerlIO::via' => '0.15',
- 'Unicode::UCD' => '0.58',
- 'XS::APItest' => '0.60_01',
- 'utf8' => '1.13_01',
- 'version' => '0.9909',
- 'version::regex' => '0.9909',
- 'version::vpp' => '0.9909',
- },
- removed => {
- }
- },
- 5.021004 => {
- delta_from => 5.021003,
- changed => {
- 'App::Prove' => '3.33',
- 'App::Prove::State' => '3.33',
- 'App::Prove::State::Result'=> '3.33',
- 'App::Prove::State::Result::Test'=> '3.33',
- 'Archive::Tar' => '2.02',
- 'Archive::Tar::Constant'=> '2.02',
- 'Archive::Tar::File' => '2.02',
- 'Attribute::Handlers' => '0.97',
- 'B' => '1.51',
- 'B::Concise' => '0.993',
- 'B::Deparse' => '1.28',
- 'B::Op_private' => '5.021004',
- 'CPAN::Meta::Requirements'=> '2.128',
- 'Config' => '5.021004',
- 'Cwd' => '3.50',
- 'Data::Dumper' => '2.154',
- 'ExtUtils::CBuilder' => '0.280219',
- 'ExtUtils::CBuilder::Base'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::Unix'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::VMS'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::Windows'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::aix'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::android'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::darwin'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280219',
- 'ExtUtils::CBuilder::Platform::os2'=> '0.280219',
- 'ExtUtils::Install' => '2.04',
- 'ExtUtils::Installed' => '2.04',
- 'ExtUtils::Liblist::Kid'=> '6.98_01',
- 'ExtUtils::Manifest' => '1.68',
- 'ExtUtils::Packlist' => '2.04',
- 'File::Find' => '1.28',
- 'File::Spec' => '3.50',
- 'File::Spec::Cygwin' => '3.50',
- 'File::Spec::Epoc' => '3.50',
- 'File::Spec::Functions' => '3.50',
- 'File::Spec::Mac' => '3.50',
- 'File::Spec::OS2' => '3.50',
- 'File::Spec::Unix' => '3.50',
- 'File::Spec::VMS' => '3.50',
- 'File::Spec::Win32' => '3.50',
- 'Getopt::Std' => '1.11',
- 'HTTP::Tiny' => '0.049',
- 'IO' => '1.34',
- 'IO::Socket::IP' => '0.32',
- 'List::Util' => '1.41',
- 'List::Util::XS' => '1.41',
- 'Locale::Codes' => '3.32',
- 'Locale::Codes::Constants'=> '3.32',
- 'Locale::Codes::Country'=> '3.32',
- 'Locale::Codes::Country_Codes'=> '3.32',
- 'Locale::Codes::Country_Retired'=> '3.32',
- 'Locale::Codes::Currency'=> '3.32',
- 'Locale::Codes::Currency_Codes'=> '3.32',
- 'Locale::Codes::Currency_Retired'=> '3.32',
- 'Locale::Codes::LangExt'=> '3.32',
- 'Locale::Codes::LangExt_Codes'=> '3.32',
- 'Locale::Codes::LangExt_Retired'=> '3.32',
- 'Locale::Codes::LangFam'=> '3.32',
- 'Locale::Codes::LangFam_Codes'=> '3.32',
- 'Locale::Codes::LangFam_Retired'=> '3.32',
- 'Locale::Codes::LangVar'=> '3.32',
- 'Locale::Codes::LangVar_Codes'=> '3.32',
- 'Locale::Codes::LangVar_Retired'=> '3.32',
- 'Locale::Codes::Language'=> '3.32',
- 'Locale::Codes::Language_Codes'=> '3.32',
- 'Locale::Codes::Language_Retired'=> '3.32',
- 'Locale::Codes::Script' => '3.32',
- 'Locale::Codes::Script_Codes'=> '3.32',
- 'Locale::Codes::Script_Retired'=> '3.32',
- 'Locale::Country' => '3.32',
- 'Locale::Currency' => '3.32',
- 'Locale::Language' => '3.32',
- 'Locale::Script' => '3.32',
- 'Math::BigFloat' => '1.9997',
- 'Math::BigInt' => '1.9997',
- 'Math::BigInt::Calc' => '1.9997',
- 'Math::BigInt::CalcEmu' => '1.9997',
- 'Module::CoreList' => '5.20140920',
- 'Module::CoreList::TieHashDelta'=> '5.20140920',
- 'Module::CoreList::Utils'=> '5.20140920',
- 'POSIX' => '1.43',
- 'Pod::Perldoc' => '3.24',
- 'Pod::Perldoc::BaseTo' => '3.24',
- 'Pod::Perldoc::GetOptsOO'=> '3.24',
- 'Pod::Perldoc::ToANSI' => '3.24',
- 'Pod::Perldoc::ToChecker'=> '3.24',
- 'Pod::Perldoc::ToMan' => '3.24',
- 'Pod::Perldoc::ToNroff' => '3.24',
- 'Pod::Perldoc::ToPod' => '3.24',
- 'Pod::Perldoc::ToRtf' => '3.24',
- 'Pod::Perldoc::ToTerm' => '3.24',
- 'Pod::Perldoc::ToText' => '3.24',
- 'Pod::Perldoc::ToTk' => '3.24',
- 'Pod::Perldoc::ToXml' => '3.24',
- 'Scalar::Util' => '1.41',
- 'Sub::Util' => '1.41',
- 'TAP::Base' => '3.33',
- 'TAP::Formatter::Base' => '3.33',
- 'TAP::Formatter::Color' => '3.33',
- 'TAP::Formatter::Console'=> '3.33',
- 'TAP::Formatter::Console::ParallelSession'=> '3.33',
- 'TAP::Formatter::Console::Session'=> '3.33',
- 'TAP::Formatter::File' => '3.33',
- 'TAP::Formatter::File::Session'=> '3.33',
- 'TAP::Formatter::Session'=> '3.33',
- 'TAP::Harness' => '3.33',
- 'TAP::Harness::Env' => '3.33',
- 'TAP::Object' => '3.33',
- 'TAP::Parser' => '3.33',
- 'TAP::Parser::Aggregator'=> '3.33',
- 'TAP::Parser::Grammar' => '3.33',
- 'TAP::Parser::Iterator' => '3.33',
- 'TAP::Parser::Iterator::Array'=> '3.33',
- 'TAP::Parser::Iterator::Process'=> '3.33',
- 'TAP::Parser::Iterator::Stream'=> '3.33',
- 'TAP::Parser::IteratorFactory'=> '3.33',
- 'TAP::Parser::Multiplexer'=> '3.33',
- 'TAP::Parser::Result' => '3.33',
- 'TAP::Parser::Result::Bailout'=> '3.33',
- 'TAP::Parser::Result::Comment'=> '3.33',
- 'TAP::Parser::Result::Plan'=> '3.33',
- 'TAP::Parser::Result::Pragma'=> '3.33',
- 'TAP::Parser::Result::Test'=> '3.33',
- 'TAP::Parser::Result::Unknown'=> '3.33',
- 'TAP::Parser::Result::Version'=> '3.33',
- 'TAP::Parser::Result::YAML'=> '3.33',
- 'TAP::Parser::ResultFactory'=> '3.33',
- 'TAP::Parser::Scheduler'=> '3.33',
- 'TAP::Parser::Scheduler::Job'=> '3.33',
- 'TAP::Parser::Scheduler::Spinner'=> '3.33',
- 'TAP::Parser::Source' => '3.33',
- 'TAP::Parser::SourceHandler'=> '3.33',
- 'TAP::Parser::SourceHandler::Executable'=> '3.33',
- 'TAP::Parser::SourceHandler::File'=> '3.33',
- 'TAP::Parser::SourceHandler::Handle'=> '3.33',
- 'TAP::Parser::SourceHandler::Perl'=> '3.33',
- 'TAP::Parser::SourceHandler::RawTAP'=> '3.33',
- 'TAP::Parser::YAMLish::Reader'=> '3.33',
- 'TAP::Parser::YAMLish::Writer'=> '3.33',
- 'Term::ReadLine' => '1.15',
- 'Test::Builder' => '1.001006',
- 'Test::Builder::Module' => '1.001006',
- 'Test::Builder::Tester' => '1.24',
- 'Test::Builder::Tester::Color'=> '1.24',
- 'Test::Harness' => '3.33',
- 'Test::More' => '1.001006',
- 'Test::Simple' => '1.001006',
- 'Time::Piece' => '1.29',
- 'Time::Seconds' => '1.29',
- 'XS::APItest' => '0.64',
- '_charnames' => '1.42',
- 'attributes' => '0.23',
- 'bigint' => '0.37',
- 'bignum' => '0.38',
- 'bigrat' => '0.37',
- 'constant' => '1.32',
- 'experimental' => '0.010',
- 'overload' => '1.23',
- 'threads' => '1.96',
- 'version' => '0.9909',
- 'version::regex' => '0.9909',
- 'version::vpp' => '0.9909',
- },
- removed => {
- }
- },
- 5.021005 => {
- delta_from => 5.021004,
- changed => {
- 'B' => '1.52',
- 'B::Concise' => '0.994',
- 'B::Debug' => '1.22',
- 'B::Deparse' => '1.29',
- 'B::Op_private' => '5.021005',
- 'CPAN::Meta' => '2.142690',
- 'CPAN::Meta::Converter' => '2.142690',
- 'CPAN::Meta::Feature' => '2.142690',
- 'CPAN::Meta::History' => '2.142690',
- 'CPAN::Meta::Merge' => '2.142690',
- 'CPAN::Meta::Prereqs' => '2.142690',
- 'CPAN::Meta::Spec' => '2.142690',
- 'CPAN::Meta::Validator' => '2.142690',
- 'Compress::Raw::Bzip2' => '2.066',
- 'Compress::Raw::Zlib' => '2.066',
- 'Compress::Zlib' => '2.066',
- 'Config' => '5.021005',
- 'Cwd' => '3.51',
- 'DynaLoader' => '1.27',
- 'Errno' => '1.21',
- 'ExtUtils::CBuilder' => '0.280220',
- 'ExtUtils::CBuilder::Base'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::Unix'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::VMS'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::Windows'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::aix'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::android'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::darwin'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280220',
- 'ExtUtils::CBuilder::Platform::os2'=> '0.280220',
- 'ExtUtils::Miniperl' => '1.03',
- 'Fcntl' => '1.13',
- 'File::Find' => '1.29',
- 'File::Spec' => '3.51',
- 'File::Spec::Cygwin' => '3.51',
- 'File::Spec::Epoc' => '3.51',
- 'File::Spec::Functions' => '3.51',
- 'File::Spec::Mac' => '3.51',
- 'File::Spec::OS2' => '3.51',
- 'File::Spec::Unix' => '3.51',
- 'File::Spec::VMS' => '3.51',
- 'File::Spec::Win32' => '3.51',
- 'HTTP::Tiny' => '0.050',
- 'IO::Compress::Adapter::Bzip2'=> '2.066',
- 'IO::Compress::Adapter::Deflate'=> '2.066',
- 'IO::Compress::Adapter::Identity'=> '2.066',
- 'IO::Compress::Base' => '2.066',
- 'IO::Compress::Base::Common'=> '2.066',
- 'IO::Compress::Bzip2' => '2.066',
- 'IO::Compress::Deflate' => '2.066',
- 'IO::Compress::Gzip' => '2.066',
- 'IO::Compress::Gzip::Constants'=> '2.066',
- 'IO::Compress::RawDeflate'=> '2.066',
- 'IO::Compress::Zip' => '2.066',
- 'IO::Compress::Zip::Constants'=> '2.066',
- 'IO::Compress::Zlib::Constants'=> '2.066',
- 'IO::Compress::Zlib::Extra'=> '2.066',
- 'IO::Uncompress::Adapter::Bunzip2'=> '2.066',
- 'IO::Uncompress::Adapter::Identity'=> '2.066',
- 'IO::Uncompress::Adapter::Inflate'=> '2.066',
- 'IO::Uncompress::AnyInflate'=> '2.066',
- 'IO::Uncompress::AnyUncompress'=> '2.066',
- 'IO::Uncompress::Base' => '2.066',
- 'IO::Uncompress::Bunzip2'=> '2.066',
- 'IO::Uncompress::Gunzip'=> '2.066',
- 'IO::Uncompress::Inflate'=> '2.066',
- 'IO::Uncompress::RawInflate'=> '2.066',
- 'IO::Uncompress::Unzip' => '2.066',
- 'JSON::PP' => '2.27300',
- 'Module::CoreList' => '5.20141020',
- 'Module::CoreList::TieHashDelta'=> '5.20141020',
- 'Module::CoreList::Utils'=> '5.20141020',
- 'Net::Cmd' => '3.02',
- 'Net::Config' => '3.02',
- 'Net::Domain' => '3.02',
- 'Net::FTP' => '3.02',
- 'Net::FTP::A' => '3.02',
- 'Net::FTP::E' => '3.02',
- 'Net::FTP::I' => '3.02',
- 'Net::FTP::L' => '3.02',
- 'Net::FTP::dataconn' => '3.02',
- 'Net::NNTP' => '3.02',
- 'Net::Netrc' => '3.02',
- 'Net::POP3' => '3.02',
- 'Net::SMTP' => '3.02',
- 'Net::Time' => '3.02',
- 'Opcode' => '1.29',
- 'POSIX' => '1.45',
- 'Socket' => '2.016',
- 'Test::Builder' => '1.001008',
- 'Test::Builder::Module' => '1.001008',
- 'Test::More' => '1.001008',
- 'Test::Simple' => '1.001008',
- 'XS::APItest' => '0.65',
- 'XSLoader' => '0.18',
- 'attributes' => '0.24',
- 'experimental' => '0.012',
- 'feature' => '1.38',
- 'perlfaq' => '5.0150046',
- 're' => '0.27',
- 'threads::shared' => '1.47',
- 'warnings' => '1.28',
- 'warnings::register' => '1.04',
- },
- removed => {
- }
- },
- 5.021006 => {
- delta_from => 5.021005,
- changed => {
- 'App::Prove' => '3.34',
- 'App::Prove::State' => '3.34',
- 'App::Prove::State::Result'=> '3.34',
- 'App::Prove::State::Result::Test'=> '3.34',
- 'B' => '1.53',
- 'B::Concise' => '0.995',
- 'B::Deparse' => '1.30',
- 'B::Op_private' => '5.021006',
- 'CPAN::Meta' => '2.143240',
- 'CPAN::Meta::Converter' => '2.143240',
- 'CPAN::Meta::Feature' => '2.143240',
- 'CPAN::Meta::History' => '2.143240',
- 'CPAN::Meta::Merge' => '2.143240',
- 'CPAN::Meta::Prereqs' => '2.143240',
- 'CPAN::Meta::Requirements'=> '2.130',
- 'CPAN::Meta::Spec' => '2.143240',
- 'CPAN::Meta::Validator' => '2.143240',
- 'Config' => '5.021006',
- 'Devel::Peek' => '1.19',
- 'Digest::SHA' => '5.93',
- 'DynaLoader' => '1.28',
- 'Encode' => '2.64',
- 'Exporter' => '5.72',
- 'Exporter::Heavy' => '5.72',
- 'ExtUtils::Command::MM' => '7.02',
- 'ExtUtils::Liblist' => '7.02',
- 'ExtUtils::Liblist::Kid'=> '7.02',
- 'ExtUtils::MM' => '7.02',
- 'ExtUtils::MM_AIX' => '7.02',
- 'ExtUtils::MM_Any' => '7.02',
- 'ExtUtils::MM_BeOS' => '7.02',
- 'ExtUtils::MM_Cygwin' => '7.02',
- 'ExtUtils::MM_DOS' => '7.02',
- 'ExtUtils::MM_Darwin' => '7.02',
- 'ExtUtils::MM_MacOS' => '7.02',
- 'ExtUtils::MM_NW5' => '7.02',
- 'ExtUtils::MM_OS2' => '7.02',
- 'ExtUtils::MM_QNX' => '7.02',
- 'ExtUtils::MM_UWIN' => '7.02',
- 'ExtUtils::MM_Unix' => '7.02',
- 'ExtUtils::MM_VMS' => '7.02',
- 'ExtUtils::MM_VOS' => '7.02',
- 'ExtUtils::MM_Win32' => '7.02',
- 'ExtUtils::MM_Win95' => '7.02',
- 'ExtUtils::MY' => '7.02',
- 'ExtUtils::MakeMaker' => '7.02',
- 'ExtUtils::MakeMaker::Config'=> '7.02',
- 'ExtUtils::MakeMaker::Locale'=> '7.02',
- 'ExtUtils::MakeMaker::version'=> '7.02',
- 'ExtUtils::MakeMaker::version::regex'=> '7.02',
- 'ExtUtils::MakeMaker::version::vpp'=> '7.02',
- 'ExtUtils::Manifest' => '1.69',
- 'ExtUtils::Mkbootstrap' => '7.02',
- 'ExtUtils::Mksymlists' => '7.02',
- 'ExtUtils::ParseXS' => '3.26',
- 'ExtUtils::ParseXS::Constants'=> '3.26',
- 'ExtUtils::ParseXS::CountLines'=> '3.26',
- 'ExtUtils::ParseXS::Eval'=> '3.26',
- 'ExtUtils::ParseXS::Utilities'=> '3.26',
- 'ExtUtils::testlib' => '7.02',
- 'File::Spec::VMS' => '3.52',
- 'HTTP::Tiny' => '0.051',
- 'I18N::Langinfo' => '0.12',
- 'IO::Socket' => '1.38',
- 'Module::CoreList' => '5.20141120',
- 'Module::CoreList::TieHashDelta'=> '5.20141120',
- 'Module::CoreList::Utils'=> '5.20141120',
- 'POSIX' => '1.46',
- 'PerlIO::encoding' => '0.20',
- 'PerlIO::scalar' => '0.20',
- 'TAP::Base' => '3.34',
- 'TAP::Formatter::Base' => '3.34',
- 'TAP::Formatter::Color' => '3.34',
- 'TAP::Formatter::Console'=> '3.34',
- 'TAP::Formatter::Console::ParallelSession'=> '3.34',
- 'TAP::Formatter::Console::Session'=> '3.34',
- 'TAP::Formatter::File' => '3.34',
- 'TAP::Formatter::File::Session'=> '3.34',
- 'TAP::Formatter::Session'=> '3.34',
- 'TAP::Harness' => '3.34',
- 'TAP::Harness::Env' => '3.34',
- 'TAP::Object' => '3.34',
- 'TAP::Parser' => '3.34',
- 'TAP::Parser::Aggregator'=> '3.34',
- 'TAP::Parser::Grammar' => '3.34',
- 'TAP::Parser::Iterator' => '3.34',
- 'TAP::Parser::Iterator::Array'=> '3.34',
- 'TAP::Parser::Iterator::Process'=> '3.34',
- 'TAP::Parser::Iterator::Stream'=> '3.34',
- 'TAP::Parser::IteratorFactory'=> '3.34',
- 'TAP::Parser::Multiplexer'=> '3.34',
- 'TAP::Parser::Result' => '3.34',
- 'TAP::Parser::Result::Bailout'=> '3.34',
- 'TAP::Parser::Result::Comment'=> '3.34',
- 'TAP::Parser::Result::Plan'=> '3.34',
- 'TAP::Parser::Result::Pragma'=> '3.34',
- 'TAP::Parser::Result::Test'=> '3.34',
- 'TAP::Parser::Result::Unknown'=> '3.34',
- 'TAP::Parser::Result::Version'=> '3.34',
- 'TAP::Parser::Result::YAML'=> '3.34',
- 'TAP::Parser::ResultFactory'=> '3.34',
- 'TAP::Parser::Scheduler'=> '3.34',
- 'TAP::Parser::Scheduler::Job'=> '3.34',
- 'TAP::Parser::Scheduler::Spinner'=> '3.34',
- 'TAP::Parser::Source' => '3.34',
- 'TAP::Parser::SourceHandler'=> '3.34',
- 'TAP::Parser::SourceHandler::Executable'=> '3.34',
- 'TAP::Parser::SourceHandler::File'=> '3.34',
- 'TAP::Parser::SourceHandler::Handle'=> '3.34',
- 'TAP::Parser::SourceHandler::Perl'=> '3.34',
- 'TAP::Parser::SourceHandler::RawTAP'=> '3.34',
- 'TAP::Parser::YAMLish::Reader'=> '3.34',
- 'TAP::Parser::YAMLish::Writer'=> '3.34',
- 'Test::Builder' => '1.301001_075',
- 'Test::Builder::Module' => '1.301001_075',
- 'Test::Builder::Tester' => '1.301001_075',
- 'Test::Builder::Tester::Color'=> '1.301001_075',
- 'Test::Harness' => '3.34',
- 'Test::More' => '1.301001_075',
- 'Test::More::DeepCheck' => undef,
- 'Test::More::DeepCheck::Strict'=> undef,
- 'Test::More::DeepCheck::Tolerant'=> undef,
- 'Test::More::Tools' => undef,
- 'Test::MostlyLike' => undef,
- 'Test::Simple' => '1.301001_075',
- 'Test::Stream' => '1.301001_075',
- 'Test::Stream::ArrayBase'=> undef,
- 'Test::Stream::ArrayBase::Meta'=> undef,
- 'Test::Stream::Carp' => undef,
- 'Test::Stream::Context' => undef,
- 'Test::Stream::Event' => undef,
- 'Test::Stream::Event::Bail'=> undef,
- 'Test::Stream::Event::Child'=> undef,
- 'Test::Stream::Event::Diag'=> undef,
- 'Test::Stream::Event::Finish'=> undef,
- 'Test::Stream::Event::Note'=> undef,
- 'Test::Stream::Event::Ok'=> undef,
- 'Test::Stream::Event::Plan'=> undef,
- 'Test::Stream::Event::Subtest'=> undef,
- 'Test::Stream::ExitMagic'=> undef,
- 'Test::Stream::ExitMagic::Context'=> undef,
- 'Test::Stream::Exporter'=> undef,
- 'Test::Stream::Exporter::Meta'=> undef,
- 'Test::Stream::IOSets' => undef,
- 'Test::Stream::Meta' => undef,
- 'Test::Stream::PackageUtil'=> undef,
- 'Test::Stream::Tester' => undef,
- 'Test::Stream::Tester::Checks'=> undef,
- 'Test::Stream::Tester::Checks::Event'=> undef,
- 'Test::Stream::Tester::Events'=> undef,
- 'Test::Stream::Tester::Events::Event'=> undef,
- 'Test::Stream::Tester::Grab'=> undef,
- 'Test::Stream::Threads' => undef,
- 'Test::Stream::Toolset' => undef,
- 'Test::Stream::Util' => undef,
- 'Test::Tester' => '1.301001_075',
- 'Test::Tester::Capture' => undef,
- 'Test::use::ok' => '1.301001_075',
- 'Unicode::UCD' => '0.59',
- 'XS::APItest' => '0.68',
- 'XSLoader' => '0.19',
- 'experimental' => '0.013',
- 'locale' => '1.05',
- 'ok' => '1.301001_075',
- 'overload' => '1.24',
- 're' => '0.28',
- 'warnings' => '1.29',
- },
- removed => {
- }
- },
- 5.021007 => {
- delta_from => 5.021006,
- changed => {
- 'Archive::Tar' => '2.04',
- 'Archive::Tar::Constant'=> '2.04',
- 'Archive::Tar::File' => '2.04',
- 'B' => '1.54',
- 'B::Concise' => '0.996',
- 'B::Deparse' => '1.31',
- 'B::Op_private' => '5.021007',
- 'B::Showlex' => '1.05',
- 'Compress::Raw::Bzip2' => '2.067',
- 'Compress::Raw::Zlib' => '2.067',
- 'Compress::Zlib' => '2.067',
- 'Config' => '5.021007',
- 'Cwd' => '3.54',
- 'DB_File' => '1.834',
- 'Data::Dumper' => '2.155',
- 'Devel::PPPort' => '3.25',
- 'Devel::Peek' => '1.20',
- 'DynaLoader' => '1.29',
- 'Encode' => '2.67',
- 'Errno' => '1.22',
- 'ExtUtils::CBuilder' => '0.280221',
- 'ExtUtils::CBuilder::Base'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::Unix'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::VMS'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::Windows'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::aix'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::android'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::darwin'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280221',
- 'ExtUtils::CBuilder::Platform::os2'=> '0.280221',
- 'ExtUtils::Command::MM' => '7.04',
- 'ExtUtils::Liblist' => '7.04',
- 'ExtUtils::Liblist::Kid'=> '7.04',
- 'ExtUtils::MM' => '7.04',
- 'ExtUtils::MM_AIX' => '7.04',
- 'ExtUtils::MM_Any' => '7.04',
- 'ExtUtils::MM_BeOS' => '7.04',
- 'ExtUtils::MM_Cygwin' => '7.04',
- 'ExtUtils::MM_DOS' => '7.04',
- 'ExtUtils::MM_Darwin' => '7.04',
- 'ExtUtils::MM_MacOS' => '7.04',
- 'ExtUtils::MM_NW5' => '7.04',
- 'ExtUtils::MM_OS2' => '7.04',
- 'ExtUtils::MM_QNX' => '7.04',
- 'ExtUtils::MM_UWIN' => '7.04',
- 'ExtUtils::MM_Unix' => '7.04',
- 'ExtUtils::MM_VMS' => '7.04',
- 'ExtUtils::MM_VOS' => '7.04',
- 'ExtUtils::MM_Win32' => '7.04',
- 'ExtUtils::MM_Win95' => '7.04',
- 'ExtUtils::MY' => '7.04',
- 'ExtUtils::MakeMaker' => '7.04',
- 'ExtUtils::MakeMaker::Config'=> '7.04',
- 'ExtUtils::MakeMaker::Locale'=> '7.04',
- 'ExtUtils::MakeMaker::version'=> '7.04',
- 'ExtUtils::MakeMaker::version::regex'=> '7.04',
- 'ExtUtils::MakeMaker::version::vpp'=> '7.04',
- 'ExtUtils::Mkbootstrap' => '7.04',
- 'ExtUtils::Mksymlists' => '7.04',
- 'ExtUtils::ParseXS' => '3.27',
- 'ExtUtils::ParseXS::Constants'=> '3.27',
- 'ExtUtils::ParseXS::CountLines'=> '3.27',
- 'ExtUtils::ParseXS::Eval'=> '3.27',
- 'ExtUtils::ParseXS::Utilities'=> '3.27',
- 'ExtUtils::testlib' => '7.04',
- 'File::Spec' => '3.53',
- 'File::Spec::Cygwin' => '3.54',
- 'File::Spec::Epoc' => '3.54',
- 'File::Spec::Functions' => '3.54',
- 'File::Spec::Mac' => '3.54',
- 'File::Spec::OS2' => '3.54',
- 'File::Spec::Unix' => '3.54',
- 'File::Spec::VMS' => '3.54',
- 'File::Spec::Win32' => '3.54',
- 'Filter::Util::Call' => '1.51',
- 'HTTP::Tiny' => '0.053',
- 'IO' => '1.35',
- 'IO::Compress::Adapter::Bzip2'=> '2.067',
- 'IO::Compress::Adapter::Deflate'=> '2.067',
- 'IO::Compress::Adapter::Identity'=> '2.067',
- 'IO::Compress::Base' => '2.067',
- 'IO::Compress::Base::Common'=> '2.067',
- 'IO::Compress::Bzip2' => '2.067',
- 'IO::Compress::Deflate' => '2.067',
- 'IO::Compress::Gzip' => '2.067',
- 'IO::Compress::Gzip::Constants'=> '2.067',
- 'IO::Compress::RawDeflate'=> '2.067',
- 'IO::Compress::Zip' => '2.067',
- 'IO::Compress::Zip::Constants'=> '2.067',
- 'IO::Compress::Zlib::Constants'=> '2.067',
- 'IO::Compress::Zlib::Extra'=> '2.067',
- 'IO::Socket::IP' => '0.34',
- 'IO::Uncompress::Adapter::Bunzip2'=> '2.067',
- 'IO::Uncompress::Adapter::Identity'=> '2.067',
- 'IO::Uncompress::Adapter::Inflate'=> '2.067',
- 'IO::Uncompress::AnyInflate'=> '2.067',
- 'IO::Uncompress::AnyUncompress'=> '2.067',
- 'IO::Uncompress::Base' => '2.067',
- 'IO::Uncompress::Bunzip2'=> '2.067',
- 'IO::Uncompress::Gunzip'=> '2.067',
- 'IO::Uncompress::Inflate'=> '2.067',
- 'IO::Uncompress::RawInflate'=> '2.067',
- 'IO::Uncompress::Unzip' => '2.067',
- 'Locale::Codes' => '3.33',
- 'Locale::Codes::Constants'=> '3.33',
- 'Locale::Codes::Country'=> '3.33',
- 'Locale::Codes::Country_Codes'=> '3.33',
- 'Locale::Codes::Country_Retired'=> '3.33',
- 'Locale::Codes::Currency'=> '3.33',
- 'Locale::Codes::Currency_Codes'=> '3.33',
- 'Locale::Codes::Currency_Retired'=> '3.33',
- 'Locale::Codes::LangExt'=> '3.33',
- 'Locale::Codes::LangExt_Codes'=> '3.33',
- 'Locale::Codes::LangExt_Retired'=> '3.33',
- 'Locale::Codes::LangFam'=> '3.33',
- 'Locale::Codes::LangFam_Codes'=> '3.33',
- 'Locale::Codes::LangFam_Retired'=> '3.33',
- 'Locale::Codes::LangVar'=> '3.33',
- 'Locale::Codes::LangVar_Codes'=> '3.33',
- 'Locale::Codes::LangVar_Retired'=> '3.33',
- 'Locale::Codes::Language'=> '3.33',
- 'Locale::Codes::Language_Codes'=> '3.33',
- 'Locale::Codes::Language_Retired'=> '3.33',
- 'Locale::Codes::Script' => '3.33',
- 'Locale::Codes::Script_Codes'=> '3.33',
- 'Locale::Codes::Script_Retired'=> '3.33',
- 'Locale::Country' => '3.33',
- 'Locale::Currency' => '3.33',
- 'Locale::Language' => '3.33',
- 'Locale::Maketext' => '1.26',
- 'Locale::Script' => '3.33',
- 'Module::CoreList' => '5.20141220',
- 'Module::CoreList::TieHashDelta'=> '5.20141220',
- 'Module::CoreList::Utils'=> '5.20141220',
- 'NDBM_File' => '1.14',
- 'Net::Cmd' => '3.04',
- 'Net::Config' => '3.04',
- 'Net::Domain' => '3.04',
- 'Net::FTP' => '3.04',
- 'Net::FTP::A' => '3.04',
- 'Net::FTP::E' => '3.04',
- 'Net::FTP::I' => '3.04',
- 'Net::FTP::L' => '3.04',
- 'Net::FTP::dataconn' => '3.04',
- 'Net::NNTP' => '3.04',
- 'Net::Netrc' => '3.04',
- 'Net::POP3' => '3.04',
- 'Net::SMTP' => '3.04',
- 'Net::Time' => '3.04',
- 'Opcode' => '1.30',
- 'POSIX' => '1.48',
- 'PerlIO::scalar' => '0.21',
- 'Pod::Escapes' => '1.07',
- 'SDBM_File' => '1.12',
- 'Storable' => '2.52',
- 'Sys::Hostname' => '1.20',
- 'Test::Builder' => '1.301001_090',
- 'Test::Builder::Module' => '1.301001_090',
- 'Test::Builder::Tester' => '1.301001_090',
- 'Test::Builder::Tester::Color'=> '1.301001_090',
- 'Test::CanFork' => undef,
- 'Test::CanThread' => undef,
- 'Test::More' => '1.301001_090',
- 'Test::Simple' => '1.301001_090',
- 'Test::Stream' => '1.301001_090',
- 'Test::Stream::API' => undef,
- 'Test::Stream::ForceExit'=> undef,
- 'Test::Stream::Subtest' => undef,
- 'Test::Tester' => '1.301001_090',
- 'Test::use::ok' => '1.301001_090',
- 'Unicode::Collate' => '1.09',
- 'Unicode::Collate::CJK::Big5'=> '1.09',
- 'Unicode::Collate::CJK::GB2312'=> '1.09',
- 'Unicode::Collate::CJK::JISX0208'=> '1.09',
- 'Unicode::Collate::CJK::Korean'=> '1.09',
- 'Unicode::Collate::CJK::Pinyin'=> '1.09',
- 'Unicode::Collate::CJK::Stroke'=> '1.09',
- 'Unicode::Collate::CJK::Zhuyin'=> '1.09',
- 'Unicode::Collate::Locale'=> '1.09',
- 'XS::APItest' => '0.69',
- 'XSLoader' => '0.20',
- '_charnames' => '1.43',
- 'arybase' => '0.09',
- 'charnames' => '1.43',
- 'feature' => '1.39',
- 'mro' => '1.17',
- 'ok' => '1.301001_090',
- 'strict' => '1.09',
- 'threads' => '1.96_001',
- },
- removed => {
- }
- },
- 5.021008 => {
- delta_from => 5.021007,
- changed => {
- 'App::Prove' => '3.35',
- 'App::Prove::State' => '3.35',
- 'App::Prove::State::Result'=> '3.35',
- 'App::Prove::State::Result::Test'=> '3.35',
- 'B' => '1.55',
- 'B::Deparse' => '1.32',
- 'B::Op_private' => '5.021008',
- 'CPAN::Meta::Requirements'=> '2.131',
- 'Compress::Raw::Bzip2' => '2.068',
- 'Compress::Raw::Zlib' => '2.068',
- 'Compress::Zlib' => '2.068',
- 'Config' => '5.021008',
- 'DB_File' => '1.835',
- 'Data::Dumper' => '2.156',
- 'Devel::PPPort' => '3.28',
- 'Devel::Peek' => '1.21',
- 'Digest::MD5' => '2.54',
- 'Digest::SHA' => '5.95',
- 'DynaLoader' => '1.30',
- 'ExtUtils::Command' => '1.20',
- 'ExtUtils::Manifest' => '1.70',
- 'Fatal' => '2.26',
- 'File::Glob' => '1.24',
- 'Filter::Util::Call' => '1.54',
- 'Getopt::Long' => '2.43',
- 'IO::Compress::Adapter::Bzip2'=> '2.068',
- 'IO::Compress::Adapter::Deflate'=> '2.068',
- 'IO::Compress::Adapter::Identity'=> '2.068',
- 'IO::Compress::Base' => '2.068',
- 'IO::Compress::Base::Common'=> '2.068',
- 'IO::Compress::Bzip2' => '2.068',
- 'IO::Compress::Deflate' => '2.068',
- 'IO::Compress::Gzip' => '2.068',
- 'IO::Compress::Gzip::Constants'=> '2.068',
- 'IO::Compress::RawDeflate'=> '2.068',
- 'IO::Compress::Zip' => '2.068',
- 'IO::Compress::Zip::Constants'=> '2.068',
- 'IO::Compress::Zlib::Constants'=> '2.068',
- 'IO::Compress::Zlib::Extra'=> '2.068',
- 'IO::Socket::IP' => '0.36',
- 'IO::Uncompress::Adapter::Bunzip2'=> '2.068',
- 'IO::Uncompress::Adapter::Identity'=> '2.068',
- 'IO::Uncompress::Adapter::Inflate'=> '2.068',
- 'IO::Uncompress::AnyInflate'=> '2.068',
- 'IO::Uncompress::AnyUncompress'=> '2.068',
- 'IO::Uncompress::Base' => '2.068',
- 'IO::Uncompress::Bunzip2'=> '2.068',
- 'IO::Uncompress::Gunzip'=> '2.068',
- 'IO::Uncompress::Inflate'=> '2.068',
- 'IO::Uncompress::RawInflate'=> '2.068',
- 'IO::Uncompress::Unzip' => '2.068',
- 'MIME::Base64' => '3.15',
- 'Module::CoreList' => '5.20150220',
- 'Module::CoreList::TieHashDelta'=> '5.20150220',
- 'Module::CoreList::Utils'=> '5.20150220',
- 'Module::Load::Conditional'=> '0.64',
- 'Module::Metadata' => '1.000026',
- 'Net::Cmd' => '3.05',
- 'Net::Config' => '3.05',
- 'Net::Domain' => '3.05',
- 'Net::FTP' => '3.05',
- 'Net::FTP::A' => '3.05',
- 'Net::FTP::E' => '3.05',
- 'Net::FTP::I' => '3.05',
- 'Net::FTP::L' => '3.05',
- 'Net::FTP::dataconn' => '3.05',
- 'Net::NNTP' => '3.05',
- 'Net::Netrc' => '3.05',
- 'Net::POP3' => '3.05',
- 'Net::SMTP' => '3.05',
- 'Net::Time' => '3.05',
- 'Opcode' => '1.31',
- 'POSIX' => '1.49',
- 'PerlIO::encoding' => '0.21',
- 'Pod::Simple' => '3.29',
- 'Pod::Simple::BlackBox' => '3.29',
- 'Pod::Simple::Checker' => '3.29',
- 'Pod::Simple::Debug' => '3.29',
- 'Pod::Simple::DumpAsText'=> '3.29',
- 'Pod::Simple::DumpAsXML'=> '3.29',
- 'Pod::Simple::HTML' => '3.29',
- 'Pod::Simple::HTMLBatch'=> '3.29',
- 'Pod::Simple::LinkSection'=> '3.29',
- 'Pod::Simple::Methody' => '3.29',
- 'Pod::Simple::Progress' => '3.29',
- 'Pod::Simple::PullParser'=> '3.29',
- 'Pod::Simple::PullParserEndToken'=> '3.29',
- 'Pod::Simple::PullParserStartToken'=> '3.29',
- 'Pod::Simple::PullParserTextToken'=> '3.29',
- 'Pod::Simple::PullParserToken'=> '3.29',
- 'Pod::Simple::RTF' => '3.29',
- 'Pod::Simple::Search' => '3.29',
- 'Pod::Simple::SimpleTree'=> '3.29',
- 'Pod::Simple::Text' => '3.29',
- 'Pod::Simple::TextContent'=> '3.29',
- 'Pod::Simple::TiedOutFH'=> '3.29',
- 'Pod::Simple::Transcode'=> '3.29',
- 'Pod::Simple::TranscodeDumb'=> '3.29',
- 'Pod::Simple::TranscodeSmart'=> '3.29',
- 'Pod::Simple::XHTML' => '3.29',
- 'Pod::Simple::XMLOutStream'=> '3.29',
- 'SDBM_File' => '1.13',
- 'Safe' => '2.39',
- 'TAP::Base' => '3.35',
- 'TAP::Formatter::Base' => '3.35',
- 'TAP::Formatter::Color' => '3.35',
- 'TAP::Formatter::Console'=> '3.35',
- 'TAP::Formatter::Console::ParallelSession'=> '3.35',
- 'TAP::Formatter::Console::Session'=> '3.35',
- 'TAP::Formatter::File' => '3.35',
- 'TAP::Formatter::File::Session'=> '3.35',
- 'TAP::Formatter::Session'=> '3.35',
- 'TAP::Harness' => '3.35',
- 'TAP::Harness::Env' => '3.35',
- 'TAP::Object' => '3.35',
- 'TAP::Parser' => '3.35',
- 'TAP::Parser::Aggregator'=> '3.35',
- 'TAP::Parser::Grammar' => '3.35',
- 'TAP::Parser::Iterator' => '3.35',
- 'TAP::Parser::Iterator::Array'=> '3.35',
- 'TAP::Parser::Iterator::Process'=> '3.35',
- 'TAP::Parser::Iterator::Stream'=> '3.35',
- 'TAP::Parser::IteratorFactory'=> '3.35',
- 'TAP::Parser::Multiplexer'=> '3.35',
- 'TAP::Parser::Result' => '3.35',
- 'TAP::Parser::Result::Bailout'=> '3.35',
- 'TAP::Parser::Result::Comment'=> '3.35',
- 'TAP::Parser::Result::Plan'=> '3.35',
- 'TAP::Parser::Result::Pragma'=> '3.35',
- 'TAP::Parser::Result::Test'=> '3.35',
- 'TAP::Parser::Result::Unknown'=> '3.35',
- 'TAP::Parser::Result::Version'=> '3.35',
- 'TAP::Parser::Result::YAML'=> '3.35',
- 'TAP::Parser::ResultFactory'=> '3.35',
- 'TAP::Parser::Scheduler'=> '3.35',
- 'TAP::Parser::Scheduler::Job'=> '3.35',
- 'TAP::Parser::Scheduler::Spinner'=> '3.35',
- 'TAP::Parser::Source' => '3.35',
- 'TAP::Parser::SourceHandler'=> '3.35',
- 'TAP::Parser::SourceHandler::Executable'=> '3.35',
- 'TAP::Parser::SourceHandler::File'=> '3.35',
- 'TAP::Parser::SourceHandler::Handle'=> '3.35',
- 'TAP::Parser::SourceHandler::Perl'=> '3.35',
- 'TAP::Parser::SourceHandler::RawTAP'=> '3.35',
- 'TAP::Parser::YAMLish::Reader'=> '3.35',
- 'TAP::Parser::YAMLish::Writer'=> '3.35',
- 'Test::Builder' => '1.301001_097',
- 'Test::Builder::Module' => '1.301001_097',
- 'Test::Builder::Tester' => '1.301001_097',
- 'Test::Builder::Tester::Color'=> '1.301001_097',
- 'Test::Harness' => '3.35',
- 'Test::More' => '1.301001_097',
- 'Test::Simple' => '1.301001_097',
- 'Test::Stream' => '1.301001_097',
- 'Test::Stream::Block' => undef,
- 'Test::Tester' => '1.301001_097',
- 'Test::Tester::CaptureRunner'=> undef,
- 'Test::Tester::Delegate'=> undef,
- 'Test::use::ok' => '1.301001_097',
- 'Unicode::Collate' => '1.10',
- 'Unicode::Collate::CJK::Big5'=> '1.10',
- 'Unicode::Collate::CJK::GB2312'=> '1.10',
- 'Unicode::Collate::CJK::JISX0208'=> '1.10',
- 'Unicode::Collate::CJK::Korean'=> '1.10',
- 'Unicode::Collate::CJK::Pinyin'=> '1.10',
- 'Unicode::Collate::CJK::Stroke'=> '1.10',
- 'Unicode::Collate::CJK::Zhuyin'=> '1.10',
- 'Unicode::Collate::Locale'=> '1.10',
- 'VMS::DCLsym' => '1.06',
- 'XS::APItest' => '0.70',
- 'arybase' => '0.10',
- 'attributes' => '0.25',
- 'autodie' => '2.26',
- 'autodie::Scope::Guard' => '2.26',
- 'autodie::Scope::GuardStack'=> '2.26',
- 'autodie::ScopeUtil' => '2.26',
- 'autodie::exception' => '2.26',
- 'autodie::exception::system'=> '2.26',
- 'autodie::hints' => '2.26',
- 'autodie::skip' => '2.26',
- 'ok' => '1.301001_097',
- 're' => '0.30',
- 'warnings' => '1.30',
- },
- removed => {
- }
- },
- 5.020002 => {
- delta_from => 5.020001,
- changed => {
- 'CPAN::Author' => '5.5002',
- 'CPAN::CacheMgr' => '5.5002',
- 'CPAN::FTP' => '5.5006',
- 'CPAN::HTTP::Client' => '1.9601',
- 'CPAN::HandleConfig' => '5.5005',
- 'CPAN::Index' => '1.9601',
- 'CPAN::LWP::UserAgent' => '1.9601',
- 'CPAN::Mirrors' => '1.9601',
- 'Config' => '5.020002',
- 'Cwd' => '3.48_01',
- 'Data::Dumper' => '2.151_01',
- 'Errno' => '1.20_05',
- 'File::Spec' => '3.48_01',
- 'File::Spec::Cygwin' => '3.48_01',
- 'File::Spec::Epoc' => '3.48_01',
- 'File::Spec::Functions' => '3.48_01',
- 'File::Spec::Mac' => '3.48_01',
- 'File::Spec::OS2' => '3.48_01',
- 'File::Spec::Unix' => '3.48_01',
- 'File::Spec::VMS' => '3.48_01',
- 'File::Spec::Win32' => '3.48_01',
- 'IO::Socket' => '1.38',
- 'Module::CoreList' => '5.20150214',
- 'Module::CoreList::TieHashDelta'=> '5.20150214',
- 'Module::CoreList::Utils'=> '5.20150214',
- 'PerlIO::scalar' => '0.18_01',
- 'Pod::PlainText' => '2.07',
- 'Storable' => '2.49_01',
- 'VMS::DCLsym' => '1.05_01',
- 'VMS::Stdio' => '2.41',
- 'attributes' => '0.23',
- 'feature' => '1.36_01',
- },
- removed => {
- }
- },
- 5.021009 => {
- delta_from => 5.021008,
- changed => {
- 'B' => '1.56',
- 'B::Debug' => '1.23',
- 'B::Deparse' => '1.33',
- 'B::Op_private' => '5.021009',
- 'Benchmark' => '1.20',
- 'CPAN::Author' => '5.5002',
- 'CPAN::CacheMgr' => '5.5002',
- 'CPAN::FTP' => '5.5006',
- 'CPAN::HTTP::Client' => '1.9601',
- 'CPAN::HandleConfig' => '5.5005',
- 'CPAN::Index' => '1.9601',
- 'CPAN::LWP::UserAgent' => '1.9601',
- 'CPAN::Meta::Requirements'=> '2.132',
- 'CPAN::Mirrors' => '1.9601',
- 'Carp' => '1.35',
- 'Carp::Heavy' => '1.35',
- 'Config' => '5.021009',
- 'Config::Perl::V' => '0.23',
- 'Data::Dumper' => '2.157',
- 'Devel::Peek' => '1.22',
- 'DynaLoader' => '1.31',
- 'Encode' => '2.70',
- 'Encode::MIME::Header' => '2.16',
- 'Errno' => '1.23',
- 'ExtUtils::Miniperl' => '1.04',
- 'HTTP::Tiny' => '0.054',
- 'Module::CoreList' => '5.20150220',
- 'Module::CoreList::TieHashDelta'=> '5.20150220',
- 'Module::CoreList::Utils'=> '5.20150220',
- 'Opcode' => '1.32',
- 'POSIX' => '1.51',
- 'Perl::OSType' => '1.008',
- 'PerlIO::scalar' => '0.22',
- 'Pod::Find' => '1.63',
- 'Pod::InputObjects' => '1.63',
- 'Pod::ParseUtils' => '1.63',
- 'Pod::Parser' => '1.63',
- 'Pod::Perldoc' => '3.25',
- 'Pod::Perldoc::BaseTo' => '3.25',
- 'Pod::Perldoc::GetOptsOO'=> '3.25',
- 'Pod::Perldoc::ToANSI' => '3.25',
- 'Pod::Perldoc::ToChecker'=> '3.25',
- 'Pod::Perldoc::ToMan' => '3.25',
- 'Pod::Perldoc::ToNroff' => '3.25',
- 'Pod::Perldoc::ToPod' => '3.25',
- 'Pod::Perldoc::ToRtf' => '3.25',
- 'Pod::Perldoc::ToTerm' => '3.25',
- 'Pod::Perldoc::ToText' => '3.25',
- 'Pod::Perldoc::ToTk' => '3.25',
- 'Pod::Perldoc::ToXml' => '3.25',
- 'Pod::PlainText' => '2.07',
- 'Pod::Select' => '1.63',
- 'Socket' => '2.018',
- 'Storable' => '2.53',
- 'Test::Builder' => '1.301001_098',
- 'Test::Builder::Module' => '1.301001_098',
- 'Test::Builder::Tester' => '1.301001_098',
- 'Test::Builder::Tester::Color'=> '1.301001_098',
- 'Test::More' => '1.301001_098',
- 'Test::Simple' => '1.301001_098',
- 'Test::Stream' => '1.301001_098',
- 'Test::Tester' => '1.301001_098',
- 'Test::use::ok' => '1.301001_098',
- 'Unicode::Collate' => '1.11',
- 'Unicode::Collate::CJK::Big5'=> '1.11',
- 'Unicode::Collate::CJK::GB2312'=> '1.11',
- 'Unicode::Collate::CJK::JISX0208'=> '1.11',
- 'Unicode::Collate::CJK::Korean'=> '1.11',
- 'Unicode::Collate::CJK::Pinyin'=> '1.11',
- 'Unicode::Collate::CJK::Stroke'=> '1.11',
- 'Unicode::Collate::CJK::Zhuyin'=> '1.11',
- 'Unicode::Collate::Locale'=> '1.11',
- 'Unicode::UCD' => '0.61',
- 'VMS::Stdio' => '2.41',
- 'Win32' => '0.51',
- 'Win32API::File' => '0.1202',
- 'attributes' => '0.26',
- 'bigint' => '0.39',
- 'bignum' => '0.39',
- 'bigrat' => '0.39',
- 'constant' => '1.33',
- 'encoding' => '2.13',
- 'feature' => '1.40',
- 'ok' => '1.301001_098',
- 'overload' => '1.25',
- 'perlfaq' => '5.021009',
- 're' => '0.31',
- 'threads::shared' => '1.48',
- 'warnings' => '1.31',
- },
- removed => {
- }
- },
- 5.021010 => {
- delta_from => 5.021009,
- changed => {
- 'App::Cpan' => '1.63',
- 'B' => '1.57',
- 'B::Deparse' => '1.34',
- 'B::Op_private' => '5.021010',
- 'Benchmark' => '1.2',
- 'CPAN' => '2.10',
- 'CPAN::Distribution' => '2.04',
- 'CPAN::FirstTime' => '5.5307',
- 'CPAN::HTTP::Credentials'=> '1.9601',
- 'CPAN::HandleConfig' => '5.5006',
- 'CPAN::Meta' => '2.150001',
- 'CPAN::Meta::Converter' => '2.150001',
- 'CPAN::Meta::Feature' => '2.150001',
- 'CPAN::Meta::History' => '2.150001',
- 'CPAN::Meta::Merge' => '2.150001',
- 'CPAN::Meta::Prereqs' => '2.150001',
- 'CPAN::Meta::Spec' => '2.150001',
- 'CPAN::Meta::Validator' => '2.150001',
- 'CPAN::Module' => '5.5002',
- 'CPAN::Plugin' => '0.95',
- 'CPAN::Plugin::Specfile'=> '0.01',
- 'CPAN::Shell' => '5.5005',
- 'Carp' => '1.36',
- 'Carp::Heavy' => '1.36',
- 'Config' => '5.02101',
- 'Cwd' => '3.55',
- 'DB' => '1.08',
- 'Data::Dumper' => '2.158',
- 'Devel::PPPort' => '3.31',
- 'DynaLoader' => '1.32',
- 'Encode' => '2.72',
- 'Encode::Alias' => '2.19',
- 'File::Spec' => '3.55',
- 'File::Spec::Cygwin' => '3.55',
- 'File::Spec::Epoc' => '3.55',
- 'File::Spec::Functions' => '3.55',
- 'File::Spec::Mac' => '3.55',
- 'File::Spec::OS2' => '3.55',
- 'File::Spec::Unix' => '3.55',
- 'File::Spec::VMS' => '3.55',
- 'File::Spec::Win32' => '3.55',
- 'Getopt::Long' => '2.45',
- 'Locale::Codes' => '3.34',
- 'Locale::Codes::Constants'=> '3.34',
- 'Locale::Codes::Country'=> '3.34',
- 'Locale::Codes::Country_Codes'=> '3.34',
- 'Locale::Codes::Country_Retired'=> '3.34',
- 'Locale::Codes::Currency'=> '3.34',
- 'Locale::Codes::Currency_Codes'=> '3.34',
- 'Locale::Codes::Currency_Retired'=> '3.34',
- 'Locale::Codes::LangExt'=> '3.34',
- 'Locale::Codes::LangExt_Codes'=> '3.34',
- 'Locale::Codes::LangExt_Retired'=> '3.34',
- 'Locale::Codes::LangFam'=> '3.34',
- 'Locale::Codes::LangFam_Codes'=> '3.34',
- 'Locale::Codes::LangFam_Retired'=> '3.34',
- 'Locale::Codes::LangVar'=> '3.34',
- 'Locale::Codes::LangVar_Codes'=> '3.34',
- 'Locale::Codes::LangVar_Retired'=> '3.34',
- 'Locale::Codes::Language'=> '3.34',
- 'Locale::Codes::Language_Codes'=> '3.34',
- 'Locale::Codes::Language_Retired'=> '3.34',
- 'Locale::Codes::Script' => '3.34',
- 'Locale::Codes::Script_Codes'=> '3.34',
- 'Locale::Codes::Script_Retired'=> '3.34',
- 'Locale::Country' => '3.34',
- 'Locale::Currency' => '3.34',
- 'Locale::Language' => '3.34',
- 'Locale::Script' => '3.34',
- 'Module::CoreList' => '5.20150320',
- 'Module::CoreList::TieHashDelta'=> '5.20150320',
- 'Module::CoreList::Utils'=> '5.20150320',
- 'POSIX' => '1.52',
- 'Pod::Functions' => '1.09',
- 'Pod::Functions::Functions'=> '1.09',
- 'Term::Complete' => '1.403',
- 'Test::Builder' => '1.001014',
- 'Test::Builder::IO::Scalar'=> '2.113',
- 'Test::Builder::Module' => '1.001014',
- 'Test::Builder::Tester' => '1.28',
- 'Test::Builder::Tester::Color'=> '1.290001',
- 'Test::More' => '1.001014',
- 'Test::Simple' => '1.001014',
- 'Test::Tester' => '0.114',
- 'Test::use::ok' => '0.16',
- 'Text::Balanced' => '2.03',
- 'Text::ParseWords' => '3.30',
- 'Unicode::Collate' => '1.12',
- 'Unicode::Collate::CJK::Big5'=> '1.12',
- 'Unicode::Collate::CJK::GB2312'=> '1.12',
- 'Unicode::Collate::CJK::JISX0208'=> '1.12',
- 'Unicode::Collate::CJK::Korean'=> '1.12',
- 'Unicode::Collate::CJK::Pinyin'=> '1.12',
- 'Unicode::Collate::CJK::Stroke'=> '1.12',
- 'Unicode::Collate::CJK::Zhuyin'=> '1.12',
- 'Unicode::Collate::Locale'=> '1.12',
- 'XS::APItest' => '0.71',
- 'encoding' => '2.14',
- 'locale' => '1.06',
- 'meta_notation' => undef,
- 'ok' => '0.16',
- 'parent' => '0.232',
- 're' => '0.32',
- 'sigtrap' => '1.08',
- 'threads' => '2.01',
- 'utf8' => '1.15',
- },
- removed => {
- 'Test::CanFork' => 1,
- 'Test::CanThread' => 1,
- 'Test::More::DeepCheck' => 1,
- 'Test::More::DeepCheck::Strict'=> 1,
- 'Test::More::DeepCheck::Tolerant'=> 1,
- 'Test::More::Tools' => 1,
- 'Test::MostlyLike' => 1,
- 'Test::Stream' => 1,
- 'Test::Stream::API' => 1,
- 'Test::Stream::ArrayBase'=> 1,
- 'Test::Stream::ArrayBase::Meta'=> 1,
- 'Test::Stream::Block' => 1,
- 'Test::Stream::Carp' => 1,
- 'Test::Stream::Context' => 1,
- 'Test::Stream::Event' => 1,
- 'Test::Stream::Event::Bail'=> 1,
- 'Test::Stream::Event::Child'=> 1,
- 'Test::Stream::Event::Diag'=> 1,
- 'Test::Stream::Event::Finish'=> 1,
- 'Test::Stream::Event::Note'=> 1,
- 'Test::Stream::Event::Ok'=> 1,
- 'Test::Stream::Event::Plan'=> 1,
- 'Test::Stream::Event::Subtest'=> 1,
- 'Test::Stream::ExitMagic'=> 1,
- 'Test::Stream::ExitMagic::Context'=> 1,
- 'Test::Stream::Exporter'=> 1,
- 'Test::Stream::Exporter::Meta'=> 1,
- 'Test::Stream::ForceExit'=> 1,
- 'Test::Stream::IOSets' => 1,
- 'Test::Stream::Meta' => 1,
- 'Test::Stream::PackageUtil'=> 1,
- 'Test::Stream::Subtest' => 1,
- 'Test::Stream::Tester' => 1,
- 'Test::Stream::Tester::Checks'=> 1,
- 'Test::Stream::Tester::Checks::Event'=> 1,
- 'Test::Stream::Tester::Events'=> 1,
- 'Test::Stream::Tester::Events::Event'=> 1,
- 'Test::Stream::Tester::Grab'=> 1,
- 'Test::Stream::Threads' => 1,
- 'Test::Stream::Toolset' => 1,
- 'Test::Stream::Util' => 1,
- }
- },
- 5.021011 => {
- delta_from => 5.021010,
- changed => {
- 'B' => '1.58',
- 'B::Deparse' => '1.35',
- 'B::Op_private' => '5.021011',
- 'CPAN' => '2.11',
- 'Config' => '5.021011',
- 'Config::Perl::V' => '0.24',
- 'Cwd' => '3.56',
- 'ExtUtils::Miniperl' => '1.05',
- 'ExtUtils::ParseXS' => '3.28',
- 'ExtUtils::ParseXS::Constants'=> '3.28',
- 'ExtUtils::ParseXS::CountLines'=> '3.28',
- 'ExtUtils::ParseXS::Eval'=> '3.28',
- 'ExtUtils::ParseXS::Utilities'=> '3.28',
- 'ExtUtils::Typemaps' => '3.28',
- 'ExtUtils::Typemaps::Cmd'=> '3.28',
- 'ExtUtils::Typemaps::InputMap'=> '3.28',
- 'ExtUtils::Typemaps::OutputMap'=> '3.28',
- 'ExtUtils::Typemaps::Type'=> '3.28',
- 'File::Spec' => '3.56',
- 'File::Spec::Cygwin' => '3.56',
- 'File::Spec::Epoc' => '3.56',
- 'File::Spec::Functions' => '3.56',
- 'File::Spec::Mac' => '3.56',
- 'File::Spec::OS2' => '3.56',
- 'File::Spec::Unix' => '3.56',
- 'File::Spec::VMS' => '3.56',
- 'File::Spec::Win32' => '3.56',
- 'IO::Socket::IP' => '0.37',
- 'Module::CoreList' => '5.20150420',
- 'Module::CoreList::TieHashDelta'=> '5.20150420',
- 'Module::CoreList::Utils'=> '5.20150420',
- 'PerlIO::mmap' => '0.014',
- 'XS::APItest' => '0.72',
- 'attributes' => '0.27',
- 'if' => '0.0604',
- 'utf8' => '1.16',
- 'warnings' => '1.32',
- },
- removed => {
- }
- },
- 5.022000 => {
- delta_from => 5.021011,
- changed => {
- 'B::Op_private' => '5.022000',
- 'Config' => '5.022',
- 'ExtUtils::Command::MM' => '7.04_01',
- 'ExtUtils::Liblist' => '7.04_01',
- 'ExtUtils::Liblist::Kid'=> '7.04_01',
- 'ExtUtils::MM' => '7.04_01',
- 'ExtUtils::MM_AIX' => '7.04_01',
- 'ExtUtils::MM_Any' => '7.04_01',
- 'ExtUtils::MM_BeOS' => '7.04_01',
- 'ExtUtils::MM_Cygwin' => '7.04_01',
- 'ExtUtils::MM_DOS' => '7.04_01',
- 'ExtUtils::MM_Darwin' => '7.04_01',
- 'ExtUtils::MM_MacOS' => '7.04_01',
- 'ExtUtils::MM_NW5' => '7.04_01',
- 'ExtUtils::MM_OS2' => '7.04_01',
- 'ExtUtils::MM_QNX' => '7.04_01',
- 'ExtUtils::MM_UWIN' => '7.04_01',
- 'ExtUtils::MM_Unix' => '7.04_01',
- 'ExtUtils::MM_VMS' => '7.04_01',
- 'ExtUtils::MM_VOS' => '7.04_01',
- 'ExtUtils::MM_Win32' => '7.04_01',
- 'ExtUtils::MM_Win95' => '7.04_01',
- 'ExtUtils::MY' => '7.04_01',
- 'ExtUtils::MakeMaker' => '7.04_01',
- 'ExtUtils::MakeMaker::Config'=> '7.04_01',
- 'ExtUtils::MakeMaker::Locale'=> '7.04_01',
- 'ExtUtils::MakeMaker::version'=> '7.04_01',
- 'ExtUtils::MakeMaker::version::regex'=> '7.04_01',
- 'ExtUtils::MakeMaker::version::vpp'=> '7.04_01',
- 'ExtUtils::Mkbootstrap' => '7.04_01',
- 'ExtUtils::Mksymlists' => '7.04_01',
- 'ExtUtils::testlib' => '7.04_01',
- 'Module::CoreList' => '5.20150520',
- 'Module::CoreList::TieHashDelta'=> '5.20150520',
- 'Module::CoreList::Utils'=> '5.20150520',
- 'POSIX' => '1.53',
- 'PerlIO::via::QuotedPrint'=> '0.08',
- 'overload' => '1.26',
- 'utf8' => '1.17',
- },
- removed => {
- }
- },
- 5.023000 => {
- delta_from => 5.022000,
- changed => {
- 'B::Op_private' => '5.023000',
- 'CPAN::Meta' => '2.150005',
- 'CPAN::Meta::Converter' => '2.150005',
- 'CPAN::Meta::Feature' => '2.150005',
- 'CPAN::Meta::History' => '2.150005',
- 'CPAN::Meta::Merge' => '2.150005',
- 'CPAN::Meta::Prereqs' => '2.150005',
- 'CPAN::Meta::Requirements'=> '2.133',
- 'CPAN::Meta::Spec' => '2.150005',
- 'CPAN::Meta::Validator' => '2.150005',
- 'CPAN::Meta::YAML' => '0.016',
- 'Config' => '5.023',
- 'Encode' => '2.73',
- 'ExtUtils::CBuilder' => '0.280223',
- 'ExtUtils::CBuilder::Base'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::Unix'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::VMS'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::Windows'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::aix'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::android'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::darwin'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280223',
- 'ExtUtils::CBuilder::Platform::os2'=> '0.280223',
- 'Fatal' => '2.27',
- 'Getopt::Long' => '2.46',
- 'HTTP::Tiny' => '0.056',
- 'List::Util' => '1.42_01',
- 'List::Util::XS' => '1.42_01',
- 'Locale::Codes' => '3.35',
- 'Locale::Codes::Constants'=> '3.35',
- 'Locale::Codes::Country'=> '3.35',
- 'Locale::Codes::Country_Codes'=> '3.35',
- 'Locale::Codes::Country_Retired'=> '3.35',
- 'Locale::Codes::Currency'=> '3.35',
- 'Locale::Codes::Currency_Codes'=> '3.35',
- 'Locale::Codes::Currency_Retired'=> '3.35',
- 'Locale::Codes::LangExt'=> '3.35',
- 'Locale::Codes::LangExt_Codes'=> '3.35',
- 'Locale::Codes::LangExt_Retired'=> '3.35',
- 'Locale::Codes::LangFam'=> '3.35',
- 'Locale::Codes::LangFam_Codes'=> '3.35',
- 'Locale::Codes::LangFam_Retired'=> '3.35',
- 'Locale::Codes::LangVar'=> '3.35',
- 'Locale::Codes::LangVar_Codes'=> '3.35',
- 'Locale::Codes::LangVar_Retired'=> '3.35',
- 'Locale::Codes::Language'=> '3.35',
- 'Locale::Codes::Language_Codes'=> '3.35',
- 'Locale::Codes::Language_Retired'=> '3.35',
- 'Locale::Codes::Script' => '3.35',
- 'Locale::Codes::Script_Codes'=> '3.35',
- 'Locale::Codes::Script_Retired'=> '3.35',
- 'Locale::Country' => '3.35',
- 'Locale::Currency' => '3.35',
- 'Locale::Language' => '3.35',
- 'Locale::Script' => '3.35',
- 'Math::BigFloat' => '1.999701',
- 'Math::BigInt' => '1.999701',
- 'Math::BigInt::Calc' => '1.999701',
- 'Math::BigInt::CalcEmu' => '1.999701',
- 'Math::BigRat' => '0.260801',
- 'Module::CoreList' => '5.20150620',
- 'Module::CoreList::TieHashDelta'=> '5.20150620',
- 'Module::CoreList::Utils'=> '5.20150620',
- 'Module::Metadata' => '1.000027',
- 'Net::Cmd' => '3.06',
- 'Net::Config' => '3.06',
- 'Net::Domain' => '3.06',
- 'Net::FTP' => '3.06',
- 'Net::FTP::A' => '3.06',
- 'Net::FTP::E' => '3.06',
- 'Net::FTP::I' => '3.06',
- 'Net::FTP::L' => '3.06',
- 'Net::FTP::dataconn' => '3.06',
- 'Net::NNTP' => '3.06',
- 'Net::Netrc' => '3.06',
- 'Net::POP3' => '3.06',
- 'Net::SMTP' => '3.06',
- 'Net::Time' => '3.06',
- 'POSIX' => '1.54',
- 'Parse::CPAN::Meta' => '1.4417',
- 'Pod::Simple' => '3.30',
- 'Pod::Simple::BlackBox' => '3.30',
- 'Pod::Simple::Checker' => '3.30',
- 'Pod::Simple::Debug' => '3.30',
- 'Pod::Simple::DumpAsText'=> '3.30',
- 'Pod::Simple::DumpAsXML'=> '3.30',
- 'Pod::Simple::HTML' => '3.30',
- 'Pod::Simple::HTMLBatch'=> '3.30',
- 'Pod::Simple::LinkSection'=> '3.30',
- 'Pod::Simple::Methody' => '3.30',
- 'Pod::Simple::Progress' => '3.30',
- 'Pod::Simple::PullParser'=> '3.30',
- 'Pod::Simple::PullParserEndToken'=> '3.30',
- 'Pod::Simple::PullParserStartToken'=> '3.30',
- 'Pod::Simple::PullParserTextToken'=> '3.30',
- 'Pod::Simple::PullParserToken'=> '3.30',
- 'Pod::Simple::RTF' => '3.30',
- 'Pod::Simple::Search' => '3.30',
- 'Pod::Simple::SimpleTree'=> '3.30',
- 'Pod::Simple::Text' => '3.30',
- 'Pod::Simple::TextContent'=> '3.30',
- 'Pod::Simple::TiedOutFH'=> '3.30',
- 'Pod::Simple::Transcode'=> '3.30',
- 'Pod::Simple::TranscodeDumb'=> '3.30',
- 'Pod::Simple::TranscodeSmart'=> '3.30',
- 'Pod::Simple::XHTML' => '3.30',
- 'Pod::Simple::XMLOutStream'=> '3.30',
- 'Pod::Usage' => '1.67',
- 'Scalar::Util' => '1.42_01',
- 'Socket' => '2.019',
- 'Sub::Util' => '1.42_01',
- 'Time::Piece' => '1.30',
- 'Time::Seconds' => '1.30',
- 'UNIVERSAL' => '1.13',
- 'Unicode' => '8.0.0',
- 'XS::APItest' => '0.73',
- 'autodie' => '2.27',
- 'autodie::Scope::Guard' => '2.27',
- 'autodie::Scope::GuardStack'=> '2.27',
- 'autodie::Util' => '2.27',
- 'autodie::exception' => '2.27',
- 'autodie::exception::system'=> '2.27',
- 'autodie::hints' => '2.27',
- 'autodie::skip' => '2.27',
- 'encoding' => '2.15',
- 'feature' => '1.41',
- 'parent' => '0.234',
- 'threads' => '2.02',
- },
- removed => {
- }
- },
- 5.023001 => {
- delta_from => 5.023000,
- changed => {
- 'B::Op_private' => '5.023001',
- 'Config' => '5.023001',
- 'DynaLoader' => '1.33',
- 'Encode' => '2.75',
- 'Encode::MIME::Header' => '2.17',
- 'Encode::Unicode' => '2.13',
- 'Fatal' => '2.29',
- 'File::Path' => '2.11',
- 'Getopt::Long' => '2.47',
- 'I18N::Langinfo' => '0.13',
- 'IPC::Open3' => '1.19',
- 'Module::CoreList' => '5.20150720',
- 'Module::CoreList::TieHashDelta'=> '5.20150720',
- 'Module::CoreList::Utils'=> '5.20150720',
- 'Net::Cmd' => '3.07',
- 'Net::Config' => '3.07',
- 'Net::Domain' => '3.07',
- 'Net::FTP' => '3.07',
- 'Net::FTP::A' => '3.07',
- 'Net::FTP::E' => '3.07',
- 'Net::FTP::I' => '3.07',
- 'Net::FTP::L' => '3.07',
- 'Net::FTP::dataconn' => '3.07',
- 'Net::NNTP' => '3.07',
- 'Net::Netrc' => '3.07',
- 'Net::POP3' => '3.07',
- 'Net::SMTP' => '3.07',
- 'Net::Time' => '3.07',
- 'Opcode' => '1.33',
- 'POSIX' => '1.55',
- 'PerlIO::scalar' => '0.23',
- 'Socket' => '2.020',
- 'Storable' => '2.54',
- 'Unicode::Collate' => '1.14',
- 'Unicode::Collate::CJK::Big5'=> '1.14',
- 'Unicode::Collate::CJK::GB2312'=> '1.14',
- 'Unicode::Collate::CJK::JISX0208'=> '1.14',
- 'Unicode::Collate::CJK::Korean'=> '1.14',
- 'Unicode::Collate::CJK::Pinyin'=> '1.14',
- 'Unicode::Collate::CJK::Stroke'=> '1.14',
- 'Unicode::Collate::CJK::Zhuyin'=> '1.14',
- 'Unicode::Collate::Locale'=> '1.14',
- 'Unicode::Normalize' => '1.19',
- 'XS::APItest' => '0.74',
- 'XS::Typemap' => '0.14',
- 'autodie' => '2.29',
- 'autodie::Scope::Guard' => '2.29',
- 'autodie::Scope::GuardStack'=> '2.29',
- 'autodie::Util' => '2.29',
- 'autodie::exception' => '2.29',
- 'autodie::exception::system'=> '2.29',
- 'autodie::hints' => '2.29',
- 'autodie::skip' => '2.29',
- 'encoding' => '2.16',
- 'feature' => '1.42',
- 'warnings' => '1.33',
- },
- removed => {
- 'autodie::ScopeUtil' => 1,
- }
- },
- 5.023002 => {
- delta_from => 5.023001,
- changed => {
- 'Attribute::Handlers' => '0.99',
- 'B::Op_private' => '5.023002',
- 'CPAN::Meta::YAML' => '0.017',
- 'Config' => '5.023002',
- 'Cwd' => '3.57',
- 'Encode' => '2.76',
- 'ExtUtils::ParseXS' => '3.29',
- 'ExtUtils::ParseXS::Constants'=> '3.29',
- 'ExtUtils::ParseXS::CountLines'=> '3.29',
- 'ExtUtils::ParseXS::Eval'=> '3.29',
- 'ExtUtils::ParseXS::Utilities'=> '3.29',
- 'ExtUtils::Typemaps' => '3.29',
- 'File::Find' => '1.30',
- 'File::Spec' => '3.57',
- 'File::Spec::Cygwin' => '3.57',
- 'File::Spec::Epoc' => '3.57',
- 'File::Spec::Functions' => '3.57',
- 'File::Spec::Mac' => '3.57',
- 'File::Spec::OS2' => '3.57',
- 'File::Spec::Unix' => '3.57',
- 'File::Spec::VMS' => '3.57',
- 'File::Spec::Win32' => '3.57',
- 'Filter::Util::Call' => '1.55',
- 'Hash::Util' => '0.19',
- 'Module::CoreList' => '5.20150820',
- 'Module::CoreList::TieHashDelta'=> '5.20150820',
- 'Module::CoreList::Utils'=> '5.20150820',
- 'POSIX' => '1.56',
- 'Term::Cap' => '1.17',
- 'Unicode::UCD' => '0.62',
- 'perlfaq' => '5.021010',
- },
- removed => {
- }
- },
- 5.020003 => {
- delta_from => 5.020002,
- changed => {
- 'Config' => '5.020003',
- 'Errno' => '1.20_06',
- 'Module::CoreList' => '5.20150912',
- 'Module::CoreList::TieHashDelta'=> '5.20150912',
- 'Module::CoreList::Utils'=> '5.20150912',
- },
- removed => {
- }
- },
);
sub is_core
my $final_release = removed_from($module);
- return 0 if defined($final_release) && $perl_version >= $final_release;
+ return 0 if defined($final_release) && $perl_version > $final_release;
# If a minimum version of the module was specified:
# Step through all perl releases ($prn)
my @releases = ($perl_version);
my $rel = $perl_version;
while (defined($rel)) {
- # XXX: This line is a sign of failure. -- rjbs, 2015-04-15
- my $this_delta = $delta{$rel} || $delta{ sprintf '%0.6f', $rel };
- $rel = $this_delta->{delta_from};
+ $rel = $delta{$rel}->{delta_from};
unshift(@releases, $rel) if defined($rel);
}
RELEASE:
},
5.01701 => { delta_from => 5.017009 },
5.017011 => { delta_from => 5.01701 },
+ 5.017012 => { delta_from => 5.017011 },
- 5.018 => { delta_from => 5.017011 },
+ 5.018 => { delta_from => 5.017012 },
5.018001 => {
delta_from => 5.018,
changed => {
removed => {
}
},
- 5.018003 => {
- delta_from => 5.018,
- changed => {
- },
- removed => {
- }
- },
- 5.018004 => {
- delta_from => 5.018,
- changed => {
- },
- removed => {
- }
- },
5.019 => {
delta_from => 5.018,
changed => {
},
removed => {
- 'CGI' => 1,
- 'CGI::Apache' => 1,
- 'CGI::Carp' => 1,
- 'CGI::Cookie' => 1,
- 'CGI::Fast' => 1,
- 'CGI::Pretty' => 1,
- 'CGI::Push' => 1,
- 'CGI::Switch' => 1,
- 'CGI::Util' => 1,
- 'Module::Build' => 1,
- 'Module::Build::Base' => 1,
- 'Module::Build::Compat' => 1,
- 'Module::Build::Config' => 1,
- 'Module::Build::ConfigData'=> 1,
- 'Module::Build::Cookbook'=> 1,
- 'Module::Build::Dumper' => 1,
- 'Module::Build::ModuleInfo'=> 1,
- 'Module::Build::Notes' => 1,
- 'Module::Build::PPMMaker'=> 1,
- 'Module::Build::Platform::Default'=> 1,
- 'Module::Build::Platform::MacOS'=> 1,
- 'Module::Build::Platform::Unix'=> 1,
- 'Module::Build::Platform::VMS'=> 1,
- 'Module::Build::Platform::VOS'=> 1,
- 'Module::Build::Platform::Windows'=> 1,
- 'Module::Build::Platform::aix'=> 1,
- 'Module::Build::Platform::cygwin'=> 1,
- 'Module::Build::Platform::darwin'=> 1,
- 'Module::Build::Platform::os2'=> 1,
- 'Module::Build::PodParser'=> 1,
- 'Module::Build::Version'=> 1,
- 'Module::Build::YAML' => 1,
- 'Package::Constants' => 1,
- 'Simple' => 1,
- 'inc::latest' => 1,
- }
- },
- 5.021001 => {
- delta_from => 5.021000,
- changed => {
- },
- removed => {
- }
- },
- 5.021002 => {
- delta_from => 5.021001,
- changed => {
- },
- removed => {
- }
- },
- 5.021003 => {
- delta_from => 5.021002,
- changed => {
- },
- removed => {
- }
- },
- 5.020001 => {
- delta_from => 5.020000,
- changed => {
- },
- removed => {
- }
- },
- 5.021004 => {
- delta_from => 5.021003,
- changed => {
- },
- removed => {
- }
- },
- 5.021005 => {
- delta_from => 5.021004,
- changed => {
- },
- removed => {
- }
- },
- 5.021006 => {
- delta_from => 5.021005,
- changed => {
- },
- removed => {
- }
- },
- 5.021007 => {
- delta_from => 5.021006,
- changed => {
- },
- removed => {
- }
- },
- 5.021008 => {
- delta_from => 5.021007,
- changed => {
- },
- removed => {
- }
- },
- 5.020002 => {
- delta_from => 5.020001,
- changed => {
- },
- removed => {
- }
- },
- 5.021009 => {
- delta_from => 5.021008,
- changed => {
- },
- removed => {
- }
- },
- 5.021010 => {
- delta_from => 5.021009,
- changed => {
- },
- removed => {
- }
- },
- 5.021011 => {
- delta_from => 5.02101,
- changed => {
- },
- removed => {
- }
- },
- 5.022000 => {
- delta_from => 5.021011,
- changed => {
- },
- removed => {
- }
- },
- 5.023000 => {
- delta_from => 5.022000,
- changed => {
- },
- removed => {
- }
- },
- 5.023001 => {
- delta_from => 5.023000,
- changed => {
- },
- removed => {
- }
- },
- 5.023002 => {
- delta_from => 5.023001,
- changed => {
- },
- removed => {
- }
- },
- 5.020003 => {
- delta_from => 5.020002,
- changed => {
- },
- removed => {
}
},
);
'AutoLoader' => 'cpan',
'AutoSplit' => 'cpan',
'B::Debug' => 'cpan',
- 'CGI' => 'cpan',
- 'CGI::Apache' => 'cpan',
- 'CGI::Carp' => 'cpan',
- 'CGI::Cookie' => 'cpan',
- 'CGI::Fast' => 'cpan',
- 'CGI::Pretty' => 'cpan',
- 'CGI::Push' => 'cpan',
- 'CGI::Switch' => 'cpan',
- 'CGI::Util' => 'cpan',
'CPAN' => 'cpan',
'CPAN::Author' => 'cpan',
'CPAN::Bundle' => 'cpan',
'Memoize::NDBM_File' => 'cpan',
'Memoize::SDBM_File' => 'cpan',
'Memoize::Storable' => 'cpan',
- 'Module::Build' => 'cpan',
- 'Module::Build::Base' => 'cpan',
- 'Module::Build::Compat' => 'cpan',
- 'Module::Build::Config' => 'cpan',
- 'Module::Build::ConfigData'=> 'cpan',
- 'Module::Build::Cookbook'=> 'cpan',
- 'Module::Build::Dumper' => 'cpan',
- 'Module::Build::ModuleInfo'=> 'cpan',
- 'Module::Build::Notes' => 'cpan',
- 'Module::Build::PPMMaker'=> 'cpan',
- 'Module::Build::Platform::Default'=> 'cpan',
- 'Module::Build::Platform::MacOS'=> 'cpan',
- 'Module::Build::Platform::Unix'=> 'cpan',
- 'Module::Build::Platform::VMS'=> 'cpan',
- 'Module::Build::Platform::VOS'=> 'cpan',
- 'Module::Build::Platform::Windows'=> 'cpan',
- 'Module::Build::Platform::aix'=> 'cpan',
- 'Module::Build::Platform::cygwin'=> 'cpan',
- 'Module::Build::Platform::darwin'=> 'cpan',
- 'Module::Build::Platform::os2'=> 'cpan',
- 'Module::Build::PodParser'=> 'cpan',
- 'Module::Build::Version'=> 'cpan',
- 'Module::Build::YAML' => 'cpan',
'Module::Load' => 'cpan',
'Module::Load::Conditional'=> 'cpan',
'Module::Loaded' => 'cpan',
'Net::POP3' => 'cpan',
'Net::SMTP' => 'cpan',
'Net::Time' => 'cpan',
- 'Package::Constants' => 'cpan',
'Params::Check' => 'cpan',
'Parse::CPAN::Meta' => 'cpan',
'Perl::OSType' => 'cpan',
'encoding' => 'cpan',
'encoding::warnings' => 'cpan',
'experimental' => 'cpan',
- 'inc::latest' => 'cpan',
'parent' => 'cpan',
'perlfaq' => 'cpan',
'version' => 'cpan',
'Archive::Tar::Constant'=> undef,
'Archive::Tar::File' => undef,
'B::Debug' => undef,
- 'CGI' => 'https://github.com/leejo/CGI.pm/issues',
- 'CGI::Apache' => 'https://github.com/leejo/CGI.pm/issues',
- 'CGI::Carp' => 'https://github.com/leejo/CGI.pm/issues',
- 'CGI::Cookie' => 'https://github.com/leejo/CGI.pm/issues',
- 'CGI::Fast' => 'https://github.com/leejo/cgi-fast/issues',
- 'CGI::Pretty' => 'https://github.com/leejo/CGI.pm/issues',
- 'CGI::Push' => 'https://github.com/leejo/CGI.pm/issues',
- 'CGI::Switch' => 'https://github.com/leejo/CGI.pm/issues',
- 'CGI::Util' => 'https://github.com/leejo/CGI.pm/issues',
'CPAN' => undef,
'CPAN::Author' => undef,
'CPAN::Bundle' => undef,
'CPAN::Meta::Requirements'=> 'https://github.com/dagolden/CPAN-Meta-Requirements/issues',
'CPAN::Meta::Spec' => 'https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues',
'CPAN::Meta::Validator' => 'https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues',
- 'CPAN::Meta::YAML' => 'https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues',
+ 'CPAN::Meta::YAML' => 'https://github.com/dagolden/CPAN-Meta-YAML/issues',
'CPAN::Mirrors' => undef,
'CPAN::Module' => undef,
'CPAN::Nox' => undef,
'Memoize::NDBM_File' => undef,
'Memoize::SDBM_File' => undef,
'Memoize::Storable' => undef,
- 'Module::Build' => undef,
- 'Module::Build::Base' => undef,
- 'Module::Build::Compat' => undef,
- 'Module::Build::Config' => undef,
- 'Module::Build::ConfigData'=> undef,
- 'Module::Build::Cookbook'=> undef,
- 'Module::Build::Dumper' => undef,
- 'Module::Build::ModuleInfo'=> 'http://rt.cpan.org/Public/Dist/Display.html?Name=Module-Build-Deprecated',
- 'Module::Build::Notes' => undef,
- 'Module::Build::PPMMaker'=> undef,
- 'Module::Build::Platform::Default'=> undef,
- 'Module::Build::Platform::MacOS'=> undef,
- 'Module::Build::Platform::Unix'=> undef,
- 'Module::Build::Platform::VMS'=> undef,
- 'Module::Build::Platform::VOS'=> undef,
- 'Module::Build::Platform::Windows'=> undef,
- 'Module::Build::Platform::aix'=> undef,
- 'Module::Build::Platform::cygwin'=> undef,
- 'Module::Build::Platform::darwin'=> undef,
- 'Module::Build::Platform::os2'=> undef,
- 'Module::Build::PodParser'=> undef,
- 'Module::Build::Version'=> 'http://rt.cpan.org/Public/Dist/Display.html?Name=Module-Build-Deprecated',
- 'Module::Build::YAML' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Module-Build-Deprecated',
'Module::Load' => undef,
'Module::Load::Conditional'=> undef,
'Module::Loaded' => undef,
'Net::POP3' => undef,
'Net::SMTP' => undef,
'Net::Time' => undef,
- 'Package::Constants' => undef,
'Params::Check' => undef,
- 'Parse::CPAN::Meta' => 'https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta/issues',
+ 'Parse::CPAN::Meta' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Parse-CPAN-Meta',
'Perl::OSType' => 'https://github.com/dagolden/Perl-OSType/issues',
'PerlIO::via::QuotedPrint'=> undef,
'Pod::Checker' => undef,
'Test' => undef,
'Test::Builder' => 'http://github.com/Test-More/test-more/issues/',
'Test::Builder::Module' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Builder::Tester' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Builder::Tester::Color'=> 'http://github.com/Test-More/test-more/issues/',
+ 'Test::Builder::Tester' => 'http://github.com/schwern/test-more/issues',
+ 'Test::Builder::Tester::Color'=> 'http://github.com/schwern/test-more/issues',
'Test::Harness' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness',
'Test::More' => 'http://github.com/Test-More/test-more/issues/',
'Test::Simple' => 'http://github.com/Test-More/test-more/issues/',
'encoding' => undef,
'encoding::warnings' => undef,
'experimental' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=experimental',
- 'inc::latest' => 'https://github.com/dagolden/inc-latest/issues',
'parent' => undef,
'perlfaq' => 'https://github.com/perl-doc-cats/perlfaq/issues',
- 'version' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=version',
- 'version::regex' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=version',
- 'version::vpp' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=version',
+ 'version' => undef,
+ 'version::regex' => undef,
+ 'version::vpp' => undef,
);
# Create aliases with trailing zeros for $] use
print join ', ', Module::CoreList->find_modules(qr/Data/);
# prints 'Data::Dumper'
- print join ', ',
- Module::CoreList->find_modules(qr/test::h.*::.*s/i, 5.008008);
+ print join ', ', Module::CoreList->find_modules(qr/test::h.*::.*s/i, 5.008008);
# prints 'Test::Harness::Assert, Test::Harness::Straps'
print join ", ", @{ $Module::CoreList::families{5.005} };
=item C<find_version( PERL_VERSION )>
-Takes a perl version as an argument. Upon successful completion, returns a
-reference to a hash. Each element of that hash has a key which is the name of
-a module (I<e.g.,> 'File::Path') shipped with that version of perl and a value
-which is the version number (I<e.g.,> '2.09') of that module which shipped
-with that version of perl . Returns C<undef> otherwise.
+Takes a perl version as an argument. Returns that perl version if it exists or C<undef>
+otherwise.
=item C<is_core( MODULE, [ MODULE_VERSION, [ PERL_VERSION ] ] )>
Available in version 2.77 and above.
-Returns the first perl version where the MODULE was marked as deprecated. Returns C<undef>
+Returns the first PERL_VERSION where the MODULE was marked as deprecated. Returns C<undef>
if the MODULE has not been marked as deprecated.
=item C<removed_from( MODULE )>
=head1 CAVEATS
Module::CoreList currently covers the 5.000, 5.001, 5.002, 5.003_07,
-5.004, 5.004_05, 5.005, 5.005_03, 5.005_04 and 5.7.3 releases of perl.
-
-All stable releases of perl since 5.6.0 are covered.
-
-All development releases of perl since 5.9.0 are covered.
-
+5.004, 5.004_05, 5.005, 5.005_03, 5.005_04, 5.6.0, 5.6.1, 5.6.2, 5.7.3,
+5.8.0, 5.8.1, 5.8.2, 5.8.3, 5.8.4, 5.8.5, 5.8.6, 5.8.7, 5.8.8, 5.8.9,
+5.9.0, 5.9.1, 5.9.2, 5.9.3, 5.9.4, 5.9.5, 5.10.0, 5.10.1, 5.11.0, 5.11.1,
+5.11.2, 5.11.3, 5.11.4, 5.11.5, 5.12.0, 5.12.1, 5.12.2, 5.12.3, 5.12.4,
+5.12.5, 5.13.0, 5.13.1, 5.13.2, 5.13.3, 5.13.4, 5.13.5, 5.13.6, 5.13.7,
+5.13.8, 5.13.9, 5.13.10, 5.13.11, 5.14.0, 5.14.1, 5.14.2 5.14.3, 5.14.4,
+5.15.0, 5.15.1, 5.15.2, 5.15.3, 5.15.4, 5.15.5, 5.15.6, 5.15.7, 5.15.8,
+5.15.9, 5.16.0, 5.16.1, 5.16.2, 5.16.3, 5.17.0, 5.17.1, 5.17.2, 5.17.3,
+5.17.4, 5.17.5, 5.17.6, 5.17.7, 5.17.8, 5.17.9, 5.17.10, 5.17.11, 5.18.0,
+5.19.0, 5.19.1, 5.19.2, 5.19.3, 5.19.4, 5.19.5, 5.19.6, 5.19.7, 5.19.8,
+5.19.9, 5.19.10, 5.19.11, 5.20.0 and 5.21.0 releases of perl.
=head1 HISTORY
use strict;
use vars qw($VERSION);
-$VERSION = '5.20150822';
+$VERSION = '5.021001';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
sub EXISTS {
my ($self, $key) = @_;
- restart:
if (exists $self->{changed}{$key}) {
return 1;
} elsif (exists $self->{removed}{$key}) {
return '';
} elsif (defined $self->{parent}) {
- $self = tied %{$self->{parent}}; #avoid extreme magic/tie recursion
- goto restart;
+ return exists $self->{parent}{$key};
}
return '';
}
use Module::CoreList;
use Module::CoreList::TieHashDelta;
-$VERSION = '5.20150822';
+$VERSION = '5.021001';
sub utilities {
my $perl = shift;
return sort keys %{ $utilities{$perl} };
}
-sub _released_order { # Sort helper, to make '?' sort after everything else
- (substr($Module::CoreList::released{$a}, 0, 1) eq "?")
- ? ((substr($Module::CoreList::released{$b}, 0, 1) eq "?")
- ? 0
- : 1)
- : ((substr($Module::CoreList::released{$b}, 0, 1) eq "?")
- ? -1
- : $Module::CoreList::released{$a} cmp $Module::CoreList::released{$b} )
-}
-
sub first_release_raw {
my $util = shift;
$util = shift if eval { $util->isa(__PACKAGE__) };
sub first_release_by_date {
my @perls = &first_release_raw;
return unless @perls;
- return (sort _released_order @perls)[0];
+ return (sort { $Module::CoreList::released{$a} cmp $Module::CoreList::released{$b} } @perls)[0];
}
sub first_release {
}
sub removed_from_by_date {
- my @perls = sort _released_order &removed_raw;
+ my @perls = sort { $Module::CoreList::released{$a} cmp $Module::CoreList::released{$b} } &removed_raw;
return shift @perls;
}
removed => {
}
},
- 5.018003 => {
- delta_from => 5.018000,
- changed => {
- },
- removed => {
- }
- },
- 5.018004 => {
- delta_from => 5.018000,
- changed => {
- },
- removed => {
- }
- },
5.019000 => {
delta_from => 5.018000,
changed => {
removed => {
}
},
- 5.021001 => {
- delta_from => 5.021000,
- changed => {
- },
- removed => {
- 'a2p' => 1,
- 'config_data' => 1,
- 'find2perl' => 1,
- 'psed' => 1,
- 's2p' => 1,
- }
- },
- 5.021002 => {
- delta_from => 5.021001,
- changed => {
- },
- removed => {
- }
- },
- 5.021003 => {
- delta_from => 5.021002,
- changed => {
- },
- removed => {
- }
- },
- 5.020001 => {
- delta_from => 5.02,
- changed => {
- },
- removed => {
- }
- },
- 5.021004 => {
- delta_from => 5.021003,
- changed => {
- },
- removed => {
- }
- },
- 5.021005 => {
- delta_from => 5.021004,
- changed => {
- },
- removed => {
- }
- },
- 5.021006 => {
- delta_from => 5.021005,
- changed => {
- },
- removed => {
- }
- },
- 5.021007 => {
- delta_from => 5.021006,
- changed => {
- },
- removed => {
- }
- },
- 5.021008 => {
- delta_from => 5.021007,
- changed => {
- },
- removed => {
- }
- },
- 5.020002 => {
- delta_from => 5.020001,
- changed => {
- },
- removed => {
- }
- },
- 5.021009 => {
- delta_from => 5.021008,
- changed => {
- 'encguess' => '1',
- },
- removed => {
- }
- },
- 5.021010 => {
- delta_from => 5.021009,
- changed => {
- },
- removed => {
- }
- },
- 5.021011 => {
- delta_from => 5.02101,
- changed => {
- },
- removed => {
- }
- },
- 5.022000 => {
- delta_from => 5.021011,
- changed => {
- },
- removed => {
- }
- },
- 5.023000 => {
- delta_from => 5.022000,
- changed => {
- },
- removed => {
- }
- },
- 5.023001 => {
- delta_from => 5.023,
- changed => {
- },
- removed => {
- }
- },
- 5.023002 => {
- delta_from => 5.023001,
- changed => {
- },
- removed => {
- }
- },
- 5.020003 => {
- delta_from => 5.020002,
- changed => {
- },
- removed => {
- }
- },
);
for my $version (sort { $a <=> $b } keys %delta) {
#!perl -w
use strict;
use Module::CoreList;
-use Test::More tests => 32;
+use Test::More tests => 25;
BEGIN { require_ok('Module::CoreList'); }
is(Module::CoreList::removed_from('CPANPLUS::inc'), 5.010001,
"CPANPLUS::inc was removed from 5.010001");
-{
- my $warnings_count = 0;
- local $SIG{__WARN__} = sub { $warnings_count++ };
- local $^W = 1;
-
- ok(exists $Module::CoreList::version{5}{strict},
- "strict was in 5");
-
- ok(!defined $Module::CoreList::version{5}{strict},
- "strict had no version in 5");
-
- is(Module::CoreList::first_release('strict', 1.01), 5.00405,
- "strict reached 1.01 with 5.00405");
-
- cmp_ok($warnings_count, '==', 0,
- "an undefined version does not produce warnings rt#123556");
-}
-
-ok(! defined(Module::CoreList->find_version()),
- "Lacking an argument, Module::CoreList->find_version() returns undef");
-my $v = 5.022;
-is(ref(Module::CoreList->find_version($v)), 'HASH',
- "With argument, Module::CoreList->find_version() returns hashref");
-$v = 5.022000;
-is(ref(Module::CoreList->find_version($v)), 'HASH',
- "With argument, Module::CoreList->find_version() returns hashref");
#!perl -w
use strict;
use Module::CoreList;
-use Test::More tests => 38;
+use Test::More tests => 34;
BEGIN { require_ok('Module::CoreList'); }
ok(Module::CoreList->is_core('DB_File', '1.01', '5.002'), "DB_File 1.01 was included in 5.002");
ok(!Module::CoreList->is_core('DB_File', '1.03', '5.002'), "DB_File 1.03 wasn't included in 5.002");
ok(Module::CoreList->is_core('DB_File', '1.03', '5.00307'), "DB_File 1.03 was included in 5.00307");
-
-ok(! Module::CoreList->is_core("CGI", undef, 5.021), "CGI not in 5.021");
-ok(! Module::CoreList->is_core("CGI", undef, 5.021001), "CGI not in 5.021001");
-
-ok( Module::CoreList::is_core("Config", 0, "5.020"), "Config v0+ is in core in 5.020");
-ok( Module::CoreList::is_core("Config", undef, "5.020"), "Config v(undef) is in core in 7.020");
is( Module::CoreList::Utils->first_release_by_date('corelist'), 5.009002, 'corelist with v5.9.2');
is( Module::CoreList::Utils::first_release_by_date('corelist'), 5.009002, 'corelist with v5.9.2');
{
- my @expected = sort qw(a2p c2ph cppstdin find2perl h2xs pstruct s2p);
+ my @expected = qw(a2p c2ph cppstdin find2perl h2xs pstruct s2p);
{
my @foo = Module::CoreList::Utils->utilities(5.001);
is_deeply( \@foo, \@expected, '5.001 utils all present and correct' );
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.48_01';
+$VERSION = '3.47';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
$pwd_cmd = "$Config::Config{targetsh} -c pwd"
}
else {
- my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh');
- $pwd_cmd = "$sh -c pwd"
+ $pwd_cmd = "$Config::Config{sh} -c pwd"
}
}
symlink[slen] = '/';
symlink[slen + 1] = 0;
}
- left_len = my_strlcat(symlink, left, sizeof(symlink));
+ left_len = my_strlcat(symlink, left, sizeof(left));
if (left_len >= sizeof(left)) {
errno = ENAMETOOLONG;
return (NULL);
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.48_01';
+$VERSION = '3.47';
$VERSION =~ tr/_//;
my %module = (MacOS => 'Mac',
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48_01';
+$VERSION = '3.47';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.48_01';
+$VERSION = '3.47';
$VERSION =~ tr/_//;
require File::Spec::Unix;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.48_01';
+$VERSION = '3.47';
$VERSION =~ tr/_//;
require Exporter;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48_01';
+$VERSION = '3.47';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48_01';
+$VERSION = '3.47';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION);
-$VERSION = '3.48_01';
+$VERSION = '3.47';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48_01';
+$VERSION = '3.47';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48_01';
+$VERSION = '3.47';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.49_01';
+$VERSION = '2.49';
BEGIN {
if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) {
The store functions will C<croak> if they run into such references
unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that
-case, the fatal message is converted to a warning and some meaningless
-string is stored instead.
+case, the fatal message is turned in a warning and some
+meaningless string is stored instead.
Setting C<$Storable::canonical> may not yield frozen strings that
compare equal due to possible stringification of numbers. When the
}
END {
- # rmtree() can indirectly load the XS object for Win32, ensure
- # we have our original sane @INC
- local @INC = @OrigINC;
# cleanup the auto/ directory we created.
rmtree([$lib_dir[0]]);
}
(void)PerlLIO_chmod(PL_oldname,PL_filemode);
#endif
if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
- /* XXX silently ignore failures */
+ int rc = 0;
#ifdef HAS_FCHOWN
- PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
+ rc = fchown(PL_lastfd,fileuid,filegid);
#else
#ifdef HAS_CHOWN
- PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid));
+ rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
#endif
#endif
+ /* XXX silently ignore failures */
+ PERL_UNUSED_VAR(rc);
}
return IoIFP(GvIOp(gv));
}
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
cmd, Strerror(e));
if (do_report) {
- /* XXX silently ignore failures */
- PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
+ int rc = PerlLIO_write(fd, (void*)&e, sizeof(int));
+ /* silently ignore failures */
+ PERL_UNUSED_VAR(rc);
PerlLIO_close(fd);
}
}
static bool
S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
const struct op_private_by_op *start = op_private_names;
- const struct op_private_by_op *const end = C_ARRAY_END(op_private_names);
+ const struct op_private_by_op *const end
+ = op_private_names + C_ARRAY_LENGTH(op_private_names);
/* This is a linear search, but no worse than the code that it replaced.
It's debugging code - size is more important than speed. */
if (HvARRAY(sv) && usedkeys) {
/* Show distribution of HEs in the ARRAY */
int freq[200];
-#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
+#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
int i;
int max = 0;
U32 pow2 = 2, keys = usedkeys;
Ap |void |set_numeric_local
Ap |void |set_numeric_radix
Ap |void |set_numeric_standard
-Admn |void |sync_locale
ApdO |void |require_pv |NN const char* pv
Apd |void |pack_cat |NN SV *cat|NN const char *pat|NN const char *patend \
|NN SV **beglist|NN SV **endlist|NN SV ***next_in_list|U32 flags
Apd |MAGIC *|sv_magicext |NN SV *const sv|NULLOK SV *const obj|const int how \
|NULLOK const MGVTBL *const vtbl|NULLOK const char *const name \
|const I32 namlen
-Ein |bool |sv_only_taint_gmagic|NN SV *sv
: exported for re.pm
EXp |MAGIC *|sv_magicext_mglob|NN SV *sv
ApdbamR |SV* |sv_mortalcopy |NULLOK SV *const oldsv
#define regprop(a,b,c,d) Perl_regprop(aTHX_ a,b,c,d)
#define report_uninit(a) Perl_report_uninit(aTHX_ a)
#define sv_magicext_mglob(a) Perl_sv_magicext_mglob(aTHX_ a)
-#define sv_only_taint_gmagic S_sv_only_taint_gmagic
#define validate_proto(a,b,c) Perl_validate_proto(aTHX_ a,b,c)
#define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a)
#define yylex() Perl_yylex(aTHX)
use Config;
use strict;
-our $VERSION = "1.20_06";
+our $VERSION = "1.20_03";
my %err = ();
{ # BeOS (support now removed) did not enter this block
# invoke CPP and read the output
- my $inhibit_linemarkers = '';
- if ($Config{gccversion} =~ /\A(\d+)\./ and $1 >= 5) {
- # GCC 5.0 interleaves expanded macros with line numbers breaking
- # each line into multiple lines. RT#123784
- $inhibit_linemarkers = ' -P';
- }
-
if ($^O eq 'VMS') {
- my $cpp = "$Config{cppstdin} $Config{cppflags}" .
- $inhibit_linemarkers . " $Config{cppminus}";
+ my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
$cpp =~ s/sys\$input//i;
open(CPPO,"$cpp errno.c |") or
die "Cannot exec $Config{cppstdin}";
} elsif ($IsMSWin32 || $^O eq 'NetWare') {
- my $cpp = "$Config{cpprun} $Config{cppflags}" .
- $inhibit_linemarkers;
- open(CPPO,"$cpp errno.c |") or
- die "Cannot run '$cpp errno.c'";
+ open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
+ die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
} elsif ($IsSymbian) {
- my $cpp = "gcc -E -I$ENV{SDK}\\epoc32\\include\\libc" .
- $inhibit_linemarkers ." -";
+ my $cpp = "gcc -E -I$ENV{SDK}\\epoc32\\include\\libc -";
open(CPPO,"$cpp < errno.c |")
or die "Cannot exec $cpp";
} else {
- my $cpp = default_cpp() . $inhibit_linemarkers;
+ my $cpp = default_cpp();
open(CPPO,"$cpp < errno.c |")
or die "Cannot exec $cpp";
}
my($name,$expr);
next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
next if $name eq $expr;
- $expr =~ s/\(?\(\s*[a-z_]\w*\s*\)\(?([^\)]+)\)?\)?/$1/i; # ((type)0xcafebabe) at alia
- $expr =~ s/\b((?:0x)?[0-9a-f]+)[LU]+\b/$1/gi; # 2147483647L et alia
- next if $expr =~ m/\b[a-z_]\w*\b/i; # skip expressions containing function names etc
+ $expr =~ s/\(?\(\s*[a-z_]\w*\s*\)([^\)]*)\)?/$1/i; # ((type)0xcafebabe) at alia
+ $expr =~ s/((?:0x)?[0-9a-fA-F]+)[luLU]+\b/$1/g; # 2147483647L et alia
+ next if $expr =~ m/^[a-zA-Z]+$/; # skip some Win32 functions
if($expr =~ m/^0[xX]/) {
$err{$name} = hex $expr;
}
plan(skip_all => "GDBM_File was not built")
unless $Config{extensions} =~ /\bGDBM_File\b/;
- # https://rt.perl.org/Public/Bug/Display.html?id=117967
- plan(skip_all => "GDBM_File is flaky in $^O")
- if $^O =~ /darwin/;
-
plan(tests => 8);
use_ok('GDBM_File');
}
=item C<atexit>
-C<atexit()> is C-specific: use C<END {}> instead, see L<perlmod>.
+C<atexit()> is C-specific: use C<END {}> instead, see L<perlsub>.
=item C<atof>
package PerlIO::scalar;
-our $VERSION = '0.18_01';
+our $VERSION = '0.18';
require XSLoader;
XSLoader::load();
1;
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
- Off_t new_posn;
switch (whence) {
case SEEK_SET:
- new_posn = offset;
+ s->posn = offset;
break;
case SEEK_CUR:
- new_posn = offset + s->posn;
+ s->posn = offset + s->posn;
break;
case SEEK_END:
{
STRLEN oldcur;
(void)SvPV(s->var, oldcur);
- new_posn = offset + oldcur;
+ s->posn = offset + oldcur;
break;
}
- default:
- SETERRNO(EINVAL, SS_IVCHAN);
- return -1;
}
- if (new_posn < 0) {
+ if (s->posn < 0) {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
- s->posn = new_posn;
return 0;
}
SV *sv = s->var;
char *p;
STRLEN len;
- STRLEN got;
+ I32 got;
p = SvPV(sv, len);
if (SvUTF8(sv)) {
if (sv_utf8_downgrade(sv, TRUE)) {
return -1;
}
}
- /* I assume that Off_t is at least as large as len (which
- * seems safe) and that the size of the buffer in our SV is
- * always less than half the size of the address space
- */
- assert(sizeof(Off_t) >= sizeof(len));
- assert((Off_t)len >= 0);
- if ((Off_t)len <= s->posn)
- return 0;
got = len - (STRLEN)(s->posn);
+ if (got <= 0)
+ return 0;
if ((STRLEN)got > (STRLEN)count)
got = (STRLEN)count;
Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
STRLEN len;
(void)SvPV(s->var,len);
- if ((Off_t)len > s->posn)
+ if (len > (STRLEN) s->posn)
return len - (STRLEN)s->posn;
else
return 0;
$| = 1;
-use Test::More tests => 120;
+use Test::More tests => 114;
my $fh;
my $var = "aaa\n";
print $refh "boo\n";
is $x, $as_string."boo\n", 'string gets appended to ref';
}
-
-SKIP:
-{ # [perl #123443]
- skip "Can't seek over 4GB with a small off_t", 4
- if $Config::Config{lseeksize} < 8;
- my $buf0 = "hello";
- open my $fh, "<", \$buf0 or die $!;
- ok(seek($fh, 2**32, SEEK_SET), "seek to a large position");
- is(read($fh, my $tmp, 1), 0, "read from a large offset");
- is($tmp, "", "should have read nothing");
- ok(eof($fh), "fh should be eof");
-}
-
-{
- my $buf0 = "hello";
- open my $fh, "<", \$buf0 or die $!;
- ok(!seek($fh, -10, SEEK_CUR), "seek to negative position");
- is(tell($fh), 0, "shouldn't change the position");
-}
package PerlIO::via;
-our $VERSION = '0.15';
+our $VERSION = '0.14';
require XSLoader;
XSLoader::load();
1;
...)
{
PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
- SV *result = Nullsv;
CV *cv =
(*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s, method, save);
+ SV *result = Nullsv;
+ va_list ap;
+ va_start(ap, flags);
if (cv != (CV *) - 1) {
IV count;
dSP;
SV *arg;
- va_list ap;
-
- va_start(ap, flags);
PUSHSTACKi(PERLSI_MAGIC);
ENTER;
PUSHMARK(sp);
while ((arg = va_arg(ap, SV *))) {
XPUSHs(arg);
}
- va_end(ap);
if (*PerlIONext(f)) {
if (!s->fh) {
GV *gv;
LEAVE;
POPSTACK;
}
+ va_end(ap);
return result;
}
*/
#ifdef BADMESS
rc = write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44);
- /* PERL_UNUSED_VAR() or PERL_UNUSED_RESULT() would be
- * useful here but that would mean pulling in perl.h */
- (void)rc;
+ (void)rc;
+
#endif
return 0;
# Package globals
@ISA = ( 'DynaLoader' );
-$VERSION = '1.05_01';
+$VERSION = '1.05';
my(%Locsyms) = ( ':ID' => 'LOCAL' );
my(%Gblsyms) = ( ':ID' => 'GLOBAL');
my $DoCache = 1;
=head1 VERSION
-1.05_01 16-Jun-2013
+1.05 12-Feb-2011
=head1 BUGS
use DynaLoader ();
use Exporter ();
-$VERSION = '2.41';
+$VERSION = '2.4';
@ISA = qw( Exporter DynaLoader IO::File );
@EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT
&O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY );
use warnings;
use Carp;
-our $VERSION = '0.60_01';
+our $VERSION = '0.60';
require XSLoader;
MGVTBL *want;
CODE:
#define test_get_this_vtable(name) \
- want = (MGVTBL*)CAT2(&PL_vtbl_, name); \
+ want = CAT2(&PL_vtbl_, name); \
have = get_vtbl(CAT2(want_vtbl_, name)); \
if (have != want) \
croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
skip_all("clone_with_stack requires threads");
}
-plan(5);
+plan(4);
fresh_perl_is( <<'----', <<'====', undef, "minimal clone_with_stack" );
use XS::APItest;
====
}
-
-{
- fresh_perl_is( <<'----', <<'====', undef, "with localised stuff" );
-use XS::APItest;
-$s = "outer";
-$a[0] = "anterior";
-$h{k} = "hale";
-{
- local $s = "inner";
- local $a[0] = 'posterior';
- local $h{k} = "halt";
- clone_with_stack();
-}
-print "scl: $s\n";
-print "ary: $a[0]\n";
-print "hsh: $h{k}\n";
-----
-scl: outer
-ary: anterior
-hsh: hale
-====
-
-}
package attributes;
-our $VERSION = 0.23;
+our $VERSION = 0.22;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
}
break;
default:
- if (memEQs(name, len, "shared")) {
+ if (memEQs(name, 6, "shared")) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
- varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
+ varstash = GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
ENTER;
tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
- if (!tmpgv || !isGV_with_GP(tmpgv))
+ if (!tmpgv)
return NULL;
stash = GvHV(tmpgv);
if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
numifying instead of C's "+0". */
gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
- if (gv && (cv = GvCV(gv)) && CvGV(cv)) {
+ if (gv && (cv = GvCV(gv))) {
if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
=head1 SV-Body Allocation
=for apidoc Ama|SV*|newSVpvs|const char* s
-Like C<newSVpvn>, but takes a literal C<NUL>-terminated string instead of a
-string/length pair.
+Like C<newSVpvn>, but takes a literal string instead of a string/length pair.
=for apidoc Ama|SV*|newSVpvs_flags|const char* s|U32 flags
-Like C<newSVpvn_flags>, but takes a literal C<NUL>-terminated string instead of
-a string/length pair.
+Like C<newSVpvn_flags>, but takes a literal string instead of a string/length
+pair.
=for apidoc Ama|SV*|newSVpvs_share|const char* s
-Like C<newSVpvn_share>, but takes a literal C<NUL>-terminated string instead of
-a string/length pair and omits the hash parameter.
+Like C<newSVpvn_share>, but takes a literal string instead of a string/length
+pair and omits the hash parameter.
=for apidoc Am|void|sv_catpvs_flags|SV* sv|const char* s|I32 flags
-Like C<sv_catpvn_flags>, but takes a literal C<NUL>-terminated string instead
-of a string/length pair.
+Like C<sv_catpvn_flags>, but takes a literal string instead of a
+string/length pair.
=for apidoc Am|void|sv_catpvs_nomg|SV* sv|const char* s
Like C<sv_catpvn_nomg>, but takes a literal string instead of a
=head1 Memory Management
=for apidoc Ama|char*|savepvs|const char* s
-Like C<savepvn>, but takes a literal C<NUL>-terminated string instead of a
-string/length pair.
+Like C<savepvn>, but takes a literal string instead of a string/length pair.
=for apidoc Ama|char*|savesharedpvs|const char* s
A version of C<savepvs()> which allocates the duplicate string in memory
#define StructCopy(s,d,t) Copy(s,d,1,t)
#endif
-/* C_ARRAY_LENGTH is the number of elements in the C array (so you
- * want your zero-based indices to be less than but not equal to).
- *
- * C_ARRAY_END is one past the last: half-open/half-closed range,
- * not last-inclusive range. */
#define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0]))
-#define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))
+#define C_ARRAY_END(a) (a) + (sizeof(a)/sizeof((a)[0]))
#ifdef NEED_VA_COPY
# ifdef va_copy
# 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.20.3
+# mkdir -p /opt/perl-catamount/lib/perl5/5.21.0
# 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.20.3
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.21.0
# 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
# stdint.h defining INT32_MIN as (-INT32_MAX-1)
# -- Edward Moy
#
-if test -f /usr/include/stdint.h; then
- case "$(grep '^#define INT32_MIN' /usr/include/stdint.h)" in
+case "$(grep '^#define INT32_MIN' /usr/include/stdint.h)" in
*-2147483648) ccflags="${ccflags} -DINT32_MIN_BROKEN -DINT64_MIN_BROKEN" ;;
- esac
-fi
+esac
# Avoid Apple's cpp precompiler, better for extensions
if [ "X`echo | ${cc} -no-cpp-precomp -E - 2>&1 >/dev/null`" = "X" ]; then
# Allow the user to override ld, but modify it as necessary below
case "$ld" in
- '') case "$cc" in
- # If the cc is explicitly something else than cc (or empty),
- # set the ld to be that explicitly something else. Conversely,
- # if the cc is 'cc' (or empty), set the ld to be 'cc'.
- cc|'') ld='cc';;
- *) ld="$cc" ;;
- esac
- ;;
+ '') ld='cc';;
esac
# Perl bundles do not expect two-level namespace, added in Darwin 1.4.
# -readonly_strings moves string constants into read-only section
# which hopefully means that modifying them leads into segmentation
# faults.
+ #
for i in -trapuv -readonly_strings
do
case "$ccflags" in
;;
esac
-# In Tru64 several slightly incompatible socket APIs are supported,
-# which one applies is chosen with a set of defines:
-# -D_SOCKADDR_LEN enables 4.4BSD and IPv6 interfaces
-# -D_POSIX_PII_SOCKET enables socklen_t instead of size_t
-for i in -D_SOCKADDR_LEN -D_POSIX_PII_SOCKET
-do
- case "$ccflags" in
- *$i*) ;;
- *) ccflags="$ccflags $i" ;;
- esac
-done
-# For OSF/1 3.2, however, defining _SOCKADDR_LEN would be
-# a bad idea since it breaks send() and recv().
-case "$ccflags" in
-*DEC_OSF1_3_X*SOCKADDR_LEN*)
- ccflags=`echo " $ccflags " | sed -e 's/ -D_SOCKADDR_LEN / /'`
- ;;
-esac
-
#
# Unset temporary variables no more needed.
#
case "X$optimize" in
X)
case `gcc -v 2>&1|grep "gcc version"` in
- "gcc version 1."*|"gcc version 2."*)
- optimize="-O2 -malign-loops=2 -malign-jumps=2 -malign-functions=2" ;;
- *)
+ "gcc version 3."*)
optimize="-O2 -falign-loops=2 -falign-jumps=2 -falign-functions=2" ;;
+ *)
+ optimize="-O2 -malign-loops=2 -malign-jumps=2 -malign-functions=2" ;;
esac
ldflags='-s'
;;
# has prompted the user for the C compiler to use.
case "$cc" in
-*gcc*)
- # With cc we can use -c99, but with gcc we just can't use C99 headers.
- # (There is a hidden define __c99 that cc uses, but trying to use that
- # with gcc leads into magnificent explosions.)
- i_stdint='undef'
- ;;
+*gcc*) ;;
*) ccversion=`cc -version 2>&1` ;;
esac
# Warnings to turn off because the source code hasn't
# been cleaned up enough yet to satisfy the IRIX cc.
- # 1047: macro redefinitions (in IRIX' own system headers!)
# 1184: "=" is used where where "==" may have been intended.
# 1552: The variable "foobar" is set but never used.
woff=1184,1552
'-O') optimize='-O3 -OPT:Olimit=0:space=ON' ;;
*) ;;
esac
- # Perl source has just grown too chummy with c99
- # (headerwise, not code-wise: we use <stdint.h> and such)
- ccflags="$ccflags -c99"
;;
*6.2*) # Ragnarok 6.2
ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff $woff"
;;
esac
-# There is a devious bug in the MIPSpro 7.4 compiler:
-# memcmp() is an inlined intrinsic, and "sometimes" it gets compiled wrong.
-#
-# In Perl the most obvious hit is regcomp.c:S_regpposixcc(),
-# causing bus errors when compiling the POSIX character classes like
-# /[[:digit:]], which means that miniperl cannot build perl.
-# (That is almost only the one victim: one single test in re/pat fails, also.)
-#
-# Therefore let's turn the inline intrinsics off and let the normal
-# libc versions be used instead. This may cause a performance hit
-# but a little slower is better than zero speed.
-#
-# MIPSpro C 7.4.1m is supposed to have fixed this bug.
-#
-case "$ccversion" in
-"MIPSpro Compilers: Version 7.4")
- ccflags="$ccflags -U__INLINE_INTRINSICS"
- ;;
-esac
-
EOCCBU
# End of cc.cbu callback unit. - Allen
# Helmut Jarausch reports that Perl's malloc is rather unusable
# with IRIX, and SGI confirms the problem.
usemymalloc=${usemymalloc:-false}
-
-# Configure finds <fcntl.h> but then thinks it can use <sys/file.h>
-# instead; in IRIX this is not true because the prototype of fcntl()
-# requires explicit include of <fcntl.h>
-i_fcntl=define
$cat <<EOO >> $pwd/config.arch
osname='android'
-eval "libpth='$libpth /system/lib /vendor/lib'"
EOO
# Android is a linux variant, so run those hints.
;;
esac
case "$osvers" in
-0.8*)
- ;;
-*)
+0.9*|1.*|2.*|3.*|4.*|5.*|6.*)
d_getprotoent_r="$undef"
d_getprotobyname_r="$undef"
d_getprotobynumber_r="$undef"
d_getservbyport_r="$undef"
d_setservent_r="$undef"
d_endservent_r="$undef"
- d_gethostbyname_r="$undef"
- d_gethostbyaddr2_r="$undef"
- d_gethostbyaddr_r="$undef"
- d_sethostent_r="$undef"
- d_gethostent_r="$undef"
- d_endhostent_r="$undef"
d_getprotoent_r_proto="0"
d_getprotobyname_r_proto="0"
d_getprotobynumber_r_proto="0"
d_getservbyport_r_proto="0"
d_setservent_r_proto="0"
d_endservent_r_proto="0"
- d_gethostbyname_r_proto="0"
- d_gethostbyaddr2_r_proto="0"
- d_gethostbyaddr_r_proto="0"
- d_sethostent_r_proto="0"
- d_endhostent_r_proto="0"
- d_gethostent_r_proto="0"
;;
esac
#
ARCH=`arch | sed 's/^OpenBSD.//'`
case "${ARCH}-${osvers}" in
-alpha-2.[0-8]|mips-2.[0-8]|powerpc-2.[0-7]|m88k-[2-4].*|m88k-5.[0-2]|hppa-3.[0-5]|vax-*)
+alpha-2.[0-8]|mips-2.[0-8]|powerpc-2.[0-7]|m88k-*|hppa-*|vax-*)
test -z "$usedl" && usedl=$undef
;;
*)
# cc is gcc so we can do better than -O
# Allow a command-line override, such as -Doptimize=-g
-case "${ARCH}-${osvers}" in
-hppa-3.3|m88k-2.*|m88k-3.[0-3])
- test "$optimize" || optimize='-O0'
+case ${ARCH} in
+m88k)
+ optimize='-O0'
;;
-m88k-3.4)
- test "$optimize" || optimize='-O1'
+hppa)
+ optimize='-O0'
;;
*)
test "$optimize" || optimize='-O2'
esac
case "$osvers" in
[012].*|3.[0-6])
- # Broken up to OpenBSD 3.6, fixed in OpenBSD 3.7
+ # Broken at least up to OpenBSD 3.6, we'll see about 3.7
d_getservbyname_r=$undef ;;
esac
esac
# under a compiler other than c89.
case "$usedl" in
define)
-echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -D_SHR_ENVIRON -E -Wc,"LANGLVL(DOLLARINNAMES)",NOLOC ${1+"$@"} .$$.c | fgrep -v "??="; rm .$$.c' > cppstdin
+echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -D_SHR_ENVIRON -E -Wc,"LANGLVL(DOLLARINNAMES)",NOLOC ${1+"$@"} .$$.c | grep -v "??="; rm .$$.c' > cppstdin
;;
*)
-echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -E -Wc,"LANGLVL(DOLLARINNAMES)",NOLOC ${1+"$@"} .$$.c | fgrep -v "??="; rm .$$.c' > cppstdin
+echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -E -Wc,"LANGLVL(DOLLARINNAMES)",NOLOC ${1+"$@"} .$$.c | grep -v "??="; rm .$$.c' > cppstdin
;;
esac
`
case "$cc" in
-'') for i in `ls -r /opt/solstudio*/bin/cc` /opt/SUNWspro/bin/cc
- do
- if test -f "$i"; then
- cc=$i
- cat <<EOF >&4
+'') if test -f /opt/SUNWspro/bin/cc; then
+ cc=/opt/SUNWspro/bin/cc
+ cat <<EOF >&4
You specified no cc but you seem to have the Workshop compiler
($cc) installed, using that.
e.g. Configure -Dcc=gcc
EOF
- break
- fi
- done
+ fi
;;
esac
if $tryworkshopcc >/dev/null 2>&1; then
cc_name=`$run ./try`
if test "$cc_name" = "workshop"; then
- ccversion="`${cc:-cc} -V 2>&1|sed -n -e '1s/^[Cc][Cc9]9*: //p'`"
+ ccversion="`${cc:-cc} -V 2>&1|sed -n -e '1s/^[Cc][Cc]: //p'`"
fi
if test "$cc_name" = "workshop CC"; then
ccversion="`${cc:-CC} -V 2>&1|sed -n -e '1s/^[Cc][C]: //p'`"
d_attribute_pure='undef'
d_attribute_unused='undef'
d_attribute_warn_unused_result='undef'
- case "$cc" in
- *c99) # c99 rejects bare '-O'.
- case "$optimize" in
- ''|-O) optimize=-O3 ;;
- esac
- # Without -Xa c99 doesn't see
- # many OS interfaces.
- case "$ccflags" in
- *-Xa*) ;;
- *) ccflags="$ccflags -Xa" ;;
- esac
- ;;
- esac
;;
esac
fi
#
cat >> config.over <<'EOOVER'
if test "$d_unsetenv" = "$define" -a \
- `expr "$ccflags" : '.*-DPERL_USE_SAFE_PUTENV'` -eq 0; then
+ `expr "$ccflags" : '.*-D_PERL_USE_SAFE_PUTENV'` -eq 0; then
ccflags="$ccflags -DPERL_USE_SAFE_PUTENV"
fi
EOOVER
Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
(UV)flags);
if (!chain)
- goto ret;
+ return &PL_sv_placeholder;
if (flags & REFCOUNTED_HE_KEY_UTF8) {
/* For searching purposes, canonicalise to Latin-1 where possible. */
const char *keyend = keypv + keylen, *p;
return sv_2mortal(refcounted_he_value(chain));
}
}
- ret:
return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
}
PERL_STATIC_INLINE U32
S_perl_hash_superfast(const unsigned char * const seed, const unsigned char *str, STRLEN len) {
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((U32*)seed) + len;
U32 tmp;
int rem= len & 3;
len >>= 2;
const unsigned char *end;
int bytes_in_carry = 0; /* bytes in carry */
- I32 total_length= (I32)len;
+ I32 total_length= len;
#if defined(UNALIGNED_SAFE)
/* Handle carry: commented out as its only used in incremental mode - it never fires for us
/* Consume enough so that the next data byte is word aligned */
STRLEN i = -PTR2IV(ptr) & 3;
if(i && i <= len) {
- MURMUR_DOBYTES((int)i, h1, carry, bytes_in_carry, ptr, len);
+ MURMUR_DOBYTES(i, h1, carry, bytes_in_carry, ptr, len);
}
/* We're now aligned. Process in aligned blocks. Specialise for each possible carry count */
len -= len/4*4;
/* Append any remaining bytes into carry */
- MURMUR_DOBYTES((int)len, h1, carry, bytes_in_carry, ptr, len);
+ MURMUR_DOBYTES(len, h1, carry, bytes_in_carry, ptr, len);
if (bytes_in_carry) {
k1 = carry >> ( 4 - bytes_in_carry ) * 8;
PERL_STATIC_INLINE U32
S_perl_hash_djb2(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((U32*)seed + len);
while (str < end) {
hash = ((hash << 5) + hash) + *str++;
}
PERL_STATIC_INLINE U32
S_perl_hash_sdbm(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((U32*)seed + len);
while (str < end) {
hash = (hash << 6) + (hash << 16) - hash + *str++;
}
PERL_STATIC_INLINE U32
S_perl_hash_one_at_a_time(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((U32*)seed) + len;
while (str < end) {
hash += *str++;
hash += (hash << 10);
PERL_STATIC_INLINE U32
S_perl_hash_one_at_a_time_hard(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
const unsigned char * const end = (const unsigned char *)str + len;
- U32 hash = *((U32*)seed) + (U32)len;
+ U32 hash = *((U32*)seed) + len;
while (str < end) {
hash += (hash << 10);
/*
=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
-Test that the given C<pv> doesn't contain any internal C<NUL> characters.
+Test that the given C<pv> doesn't contain any internal NUL characters.
If it does, set C<errno> to ENOENT, optionally warn, and return FALSE.
Return TRUE if the name is safe.
}
/*
-
-Return false if any get magic is on the SV other than taint magic.
-
-*/
-
-PERL_STATIC_INLINE bool
-S_sv_only_taint_gmagic(SV *sv) {
- MAGIC *mg = SvMAGIC(sv);
-
- PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
-
- while (mg) {
- if (mg->mg_type != PERL_MAGIC_taint
- && !(mg->mg_flags & MGf_GSKIP)
- && mg->mg_virtual->svt_get) {
- return FALSE;
- }
- mg = mg->mg_moremagic;
- }
-
- return TRUE;
-}
-
-/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
if ($Is_Cygwin) {
$perldll = $libperl;
} else {
- $perldll = 'perl5'.$Config{patchlevel}.'.'.$so;
+ $perldll = 'perl5'.$Config{patchlevel}.'.'.$dlext;
}
if ($dlsrc ne "dl_none.xs") {
/* Hook for File::Glob */
PERLVARI(I, globhook, globhook_t, NULL)
-/* The last unconditional member of the interpreter structure when 5.20.3 was
+/* The last unconditional member of the interpreter structure when 5.21.0 was
released. The offset of the end of this is baked into a global variable in
any shared perl library which will allow a sanity test in future perl
releases. */
/B/Showlex.pm
/B/Terse.pm
/B/Xref.pm
-/CGI.pm
-/CGI/
/CPAN.pm
/CPAN/
/Carp.pm
/Opcode.pm
/POSIX.pm
/POSIX.pod
-/Package/
/Params/
/Parse/
/Perl/
/experimental.pm
/fields.pm
/if.pm
-/inc/
/lib.pm
/mro.pm
/ops.pm
sub cp;
sub mv;
-$VERSION = '2.30';
+$VERSION = '2.29';
require Exporter;
@ISA = qw(Exporter);
directory does exist, then it will be created. Trying to copy
a file into a non-existent directory is an error.
Trying to copy a file on top of itself is also an error.
-C<copy> will not overwrite read-only files.
If the destination (second argument) already exists and is a directory,
and the source (first argument) is not a filehandle, then the source
no warnings 'surrogate'; # surrogates can be inputs to this
use charnames ();
-our $VERSION = '0.58';
+our $VERSION = '0.57';
require Exporter;
is empty if I<code> has no decomposition; or is one or more codes
(separated by spaces) that, taken in order, represent a decomposition for
I<code>. Each has at least four hexdigits.
-The codes may be preceded by a word enclosed in angle brackets, then a space,
+The codes may be preceded by a word enclosed in angle brackets then a space,
like C<E<lt>compatE<gt> >, giving the type of decomposition
This decomposition may be an intermediate one whose components are also
=item B<decimal>
-if I<code> represents a decimal digit this is its integer numeric value
+if I<code> is a decimal digit this is its integer numeric value
=item B<digit>
my $range = charblock('Armenian');
-With a L</code point argument> C<charblock()> returns the I<block> the code point
+With a L</code point argument> charblock() returns the I<block> the code point
belongs to, e.g. C<Basic Latin>. The old-style block name is returned (see
L</Old-style versus new-style block names>).
If the code point is unassigned, this returns the block it would belong to if
See also L</Blocks versus Scripts>.
-If supplied with an argument that can't be a code point, C<charblock()> tries to
+If supplied with an argument that can't be a code point, charblock() tries to
do the opposite and interpret the argument as an old-style block name. On an
ASCII platform, the return value is a I<range set> with one range: an
anonymous list with a single element that consists of another anonymous list
whose first element is the first code point in the block, and whose second
-element is the final code point in the block. On an EBCDIC
+(and final) element is the final code point in the block. On an EBCDIC
platform, the first two Unicode blocks are not contiguous. Their range sets
-are lists containing I<start-of-range>, I<end-of-range> code point pairs. You
+are lists containing I<start-of-range>, I<end-of-range> code point pairs. You
can test whether a code point is in a range set using the L</charinrange()>
-function. (To be precise, each I<range set> contains a third array element,
-after the range boundary ones: the old_style block name.)
-
-If the argument to C<charblock()> is not a known block, C<undef> is
-returned.
+function. If the argument is not a known block, C<undef> is returned.
=cut
my $range = charscript('Thai');
-With a L</code point argument>, C<charscript()> returns the I<script> the
-code point belongs to, e.g., C<Latin>, C<Greek>, C<Han>.
+With a L</code point argument> charscript() returns the I<script> the
+code point belongs to, e.g. C<Latin>, C<Greek>, C<Han>.
If the code point is unassigned or the Unicode version being used is so early
that it doesn't have scripts, this function returns C<"Unknown">.
to do the opposite and interpret the argument as a script name. The
return value is a I<range set>: an anonymous list of lists that contain
I<start-of-range>, I<end-of-range> code point pairs. You can test whether a
-code point is in a range set using the L</charinrange()> function.
-(To be precise, each I<range set> contains a third array element,
-after the range boundary ones: the script name.)
-
-If the C<charscript()> argument is not a known script, C<undef> is returned.
+code point is in a range set using the L</charinrange()> function. If the
+argument is not a known script, C<undef> is returned.
See also L</Blocks versus Scripts>.
my $charblocks = charblocks();
-C<charblocks()> returns a reference to a hash with the known block names
+charblocks() returns a reference to a hash with the known block names
as the keys, and the code point ranges (see L</charblock()>) as the values.
The names are in the old-style (see L</Old-style versus new-style block
my $charscripts = charscripts();
-C<charscripts()> returns a reference to a hash with the known script
+charscripts() returns a reference to a hash with the known script
names as the keys, and the code point ranges (see L</charscript()>) as
the values.
In addition to using the C<\p{Blk=...}> and C<\P{Blk=...}> constructs, you
can also test whether a code point is in the I<range> as returned by
L</charblock()> and L</charscript()> or as the values of the hash returned
-by L</charblocks()> and L</charscripts()> by using C<charinrange()>:
+by L</charblocks()> and L</charscripts()> by using charinrange():
use Unicode::UCD qw(charscript charinrange);
my $compexcl = compexcl(0x09dc);
This routine returns C<undef> if the Unicode version being used is so early
-that it doesn't have this property.
-
-C<compexcl()> is included for backwards
+that it doesn't have this property. It is included for backwards
compatibility, but as of Perl 5.12 and more modern Unicode versions, for
most purposes it is probably more convenient to use one of the following
instead:
If used with a single argument in a scalar context, returns the string
consisting of the code points of the named sequence, or C<undef> if no
named sequence by that name exists. If used with a single argument in
-a list context, it returns the list of the ordinals of the code points.
-
-If used with no
-arguments in a list context, it returns a hash with the names of all the
-named sequences as the keys and their sequences as strings as
+a list context, it returns the list of the ordinals of the code points. If used
+with no
+arguments in a list context, returns a hash with the names of the
+named sequences as the keys and the named sequences as strings as
the values. Otherwise, it returns C<undef> or an empty list depending
on the context.
my $val = num("123");
my $one_quarter = num("\N{VULGAR FRACTION 1/4}");
-C<num()> returns the numeric value of the input Unicode string; or C<undef> if it
+C<num> returns the numeric value of the input Unicode string; or C<undef> if it
doesn't think the entire string has a completely valid, safe numeric value.
If the string is just one character in length, the Unicode numeric value
package feature;
-our $VERSION = '1.36_01';
+our $VERSION = '1.37';
our %feature = (
fc => 'feature_fc',
$feature_bundle{"5.18"} = $feature_bundle{"5.15"};
$feature_bundle{"5.19"} = $feature_bundle{"5.15"};
$feature_bundle{"5.20"} = $feature_bundle{"5.15"};
+$feature_bundle{"5.21"} = $feature_bundle{"5.15"};
+$feature_bundle{"5.22"} = $feature_bundle{"5.15"};
$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
our $hint_shift = 26;
This feature is available from Perl 5.18 onwards.
-=head2 The 'postderef' and 'postderef_qq' features
-
-B<WARNING>: This feature is still experimental and the implementation may
-change in future versions of Perl. For this reason, Perl will
-warn when you use the feature, unless you have explicitly disabled the
-warning:
-
- no warnings "experimental::postderef";
-
-The 'postderef' feature allows the use of L<postfix dereference
-syntax|perlref/Postfix Dereference Syntax>. For example, it will make the
-following two statements equivalent:
-
- my @x = @{ $h->{a} };
- my @x = $h->{a}->@*;
-
-The 'postderef_qq' feature extends this, for array and scalar dereference, to
-working inside of double-quotish interpolations.
-
-This feature is available from Perl 5.20 onwards.
-
=head2 The 'signatures' feature
B<WARNING>: This feature is still experimental and the implementation may
:5.20 say state switch unicode_strings
unicode_eval evalbytes current_sub fc
+ :5.22 say state switch unicode_strings
+ unicode_eval evalbytes current_sub fc
+
The C<:default> bundle represents the feature set that is enabled before
any C<use feature> or C<no feature> declaration.
stderr => 1 );
like( $result, qr/syntax OK$/, "preamble compiles");
-$result = runperl( switches => ['-I.', "-w"],
+$result = runperl( switches => ["-w"],
stderr => 1,
prog => <<'PROG' );
$SIG{__WARN__} = sub { die $_[0] }; require q(lib/h2ph.pht);
# Debugger for Perl 5.00x; perl5db.pl patch level:
use vars qw($VERSION $header);
-$VERSION = '1.44_01';
+$VERSION = '1.44';
$header = "perl5db.pl version $VERSION";
lock($DBGR);
print "Threads support enabled\n";
} else {
- *lock = sub(*) {};
*share = sub(\[$@%]) {};
}
}
$utf8::hint_bits = 0x00800000;
-our $VERSION = '1.13_01';
+our $VERSION = '1.13';
sub import {
$^H |= $utf8::hint_bits;
=over 4
-=item * C<$num_octets = utf8::upgrade($string)>
+=item * $num_octets = utf8::upgrade($string)
Converts in-place the internal representation of the string from an octet
sequence in the native encoding (Latin-1 or EBCDIC) to I<UTF-X>. The
Therefore Encode is recommended for the general purposes; see also
L<Encode>.
-=item * C<$success = utf8::downgrade($string[, $fail_ok])>
+=item * $success = utf8::downgrade($string[, $fail_ok])
Converts in-place the internal representation of the string from
I<UTF-X> to the equivalent octet sequence in the native encoding (Latin-1
Therefore Encode is recommended for the general purposes; see also
L<Encode>.
-=item * C<utf8::encode($string)>
+=item * utf8::encode($string)
Converts in-place the character sequence to the corresponding octet
sequence in I<UTF-X>. That is, every (possibly wide) character gets
Therefore Encode is recommended for the general purposes; see also
L<Encode>.
-=item * C<$success = utf8::decode($string)>
+=item * $success = utf8::decode($string)
Attempts to convert in-place the octet sequence encoded as I<UTF-X> to the
corresponding character sequence. That is, it replaces each sequence of
Therefore Encode is recommended for the general purposes; see also
L<Encode>.
-=item * C<$flag = utf8::is_utf8($string)>
+=item * $flag = utf8::is_utf8($string)
(Since Perl 5.8.1) Test whether I<$string> is marked internally as encoded in
UTF-8. Functionally the same as Encode::is_utf8().
-=item * C<$flag = utf8::valid($string)>
+=item * $flag = utf8::valid($string)
[INTERNAL] Test whether I<$string> is in a consistent state regarding
UTF-8. Will return true if it is well-formed UTF-8 and has the UTF-8 flag
* otherwise to use the particular category's variable if set; otherwise to
* use the LANG variable. */
- bool override_LC_ALL = FALSE;
+ bool override_LC_ALL = 0;
char * result;
if (locale && strEQ(locale, "")) {
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
#ifdef __GLIBC__
- const char * const language = savepv(PerlEnv_getenv("LANGUAGE"));
+ char * const language = PerlEnv_getenv("LANGUAGE");
#endif
/* NULL uses the existing already set up locale */
: "";
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 * const lang = savepv(PerlEnv_getenv("LANG"));
+ char * const lc_all = PerlEnv_getenv("LC_ALL");
+ char * const lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
unsigned int i;
char *p;
-
- /* A later getenv() could zap this, so only use here */
- const char * const bad_lang_use_once = PerlEnv_getenv("PERL_BADLANG");
-
- const bool locwarn = (printwarn > 1
- || (printwarn
- && (! bad_lang_use_once
- || atoi(bad_lang_use_once))));
+ const bool locwarn = (printwarn > 1 ||
+ (printwarn &&
+ (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
bool done = FALSE;
const char *system_default_locale = NULL;
#endif /* USE_LOCALE */
-#ifdef __GLIBC__
- Safefree(language);
-#endif
-
- Safefree(lc_all);
- Safefree(lang);
-
return ok;
}
Safefree(save_input_locale);
return is_utf8;
}
- Safefree(codeset);
}
# endif
* result */
if (is_utf8) {
wchar_t wc;
- PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */
+ GCC_DIAG_IGNORE(-Wunused-result);
+ (void) mbtowc(&wc, NULL, 0); /* Reset any shift state */
+ GCC_DIAG_RESTORE;
errno = 0;
if (mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8))
!= strlen(HYPHEN_UTF8)
# the Makefile.PL. Altering the atime and mtime backwards by 4
# seconds seems to resolve the issue.
eval {
- my $ftime = (stat('Makefile.PL'))[9] - 4;
- utime $ftime, $ftime, 'Makefile.PL';
+ my $ftime = time - 4;
+ utime $ftime, $ftime, 'Makefile.PL';
};
} elsif ($mname =~ /\A(?:Carp
|ExtUtils::CBuilder
# (which it has to deal with, as cpan/foo/bar creates
# lib/auto/foo/bar, but the EU::MM rule will only
# rmdir lib/auto/foo/bar, leaving lib/auto/foo
- _unlink($_)
+ _unlink("../../$_")
foreach sort values %pm;
}
}
Perl_my_cxt_index
);
}
-if ($define{'NO_MATHOMS'}) {
- ++$skip{$_} foreach qw(
- ASCII_TO_NEED
- NATIVE_TO_NEED
- Perl_custom_op_desc
- Perl_custom_op_name
- Perl_do_aexec
- Perl_do_binmode
- Perl_do_open
- Perl_do_open9
- Perl_fprintf_nocontext
- Perl_gv_AVadd
- Perl_gv_HVadd
- Perl_gv_IOadd
- Perl_gv_SVadd
- Perl_gv_efullname
- Perl_gv_efullname3
- Perl_gv_fetchmethod
- Perl_gv_fullname
- Perl_gv_fullname3
- Perl_hv_delete
- Perl_hv_delete_ent
- Perl_hv_exists
- Perl_hv_exists_ent
- Perl_hv_fetch
- Perl_hv_fetch_ent
- Perl_hv_iternext
- Perl_hv_magic
- Perl_hv_store
- Perl_hv_store_ent
- Perl_hv_store_flags
- Perl_init_i18nl14n
- Perl_isALNUM_lazy
- Perl_isIDFIRST_lazy
- Perl_is_uni_alnum
- Perl_is_uni_alnum_lc
- Perl_is_uni_alnumc
- Perl_is_uni_alnumc_lc
- Perl_is_uni_alpha
- Perl_is_uni_alpha_lc
- Perl_is_uni_ascii
- Perl_is_uni_ascii_lc
- Perl_is_uni_blank
- Perl_is_uni_blank_lc
- Perl_is_uni_cntrl
- Perl_is_uni_cntrl_lc
- Perl_is_uni_digit
- Perl_is_uni_digit_lc
- Perl_is_uni_graph
- Perl_is_uni_graph_lc
- Perl_is_uni_idfirst
- Perl_is_uni_idfirst_lc
- Perl_is_uni_lower
- Perl_is_uni_lower_lc
- Perl_is_uni_print
- Perl_is_uni_print_lc
- Perl_is_uni_punct
- Perl_is_uni_punct_lc
- Perl_is_uni_space
- Perl_is_uni_space_lc
- Perl_is_uni_upper
- Perl_is_uni_upper_lc
- Perl_is_uni_xdigit
- Perl_is_uni_xdigit_lc
- Perl_is_utf8_alnum
- Perl_is_utf8_alnumc
- Perl_is_utf8_alpha
- Perl_is_utf8_ascii
- Perl_is_utf8_blank
- Perl_is_utf8_char
- Perl_is_utf8_cntrl
- Perl_is_utf8_digit
- Perl_is_utf8_graph
- Perl_is_utf8_idcont
- Perl_is_utf8_idfirst
- Perl_is_utf8_lower
- Perl_is_utf8_mark
- Perl_is_utf8_perl_space
- Perl_is_utf8_perl_word
- Perl_is_utf8_posix_digit
- Perl_is_utf8_print
- Perl_is_utf8_punct
- Perl_is_utf8_space
- Perl_is_utf8_string_loc
- Perl_is_utf8_upper
- Perl_is_utf8_xdigit
- Perl_is_utf8_xidcont
- Perl_is_utf8_xidfirst
- Perl_my_lstat
- Perl_my_stat
- Perl_newAV
- Perl_newHV
- Perl_newIO
- Perl_newSUB
- Perl_pack_cat
- Perl_printf_nocontext
- Perl_ref
- Perl_save_freeop
- Perl_save_freepv
- Perl_save_freesv
- Perl_save_iv
- Perl_save_list
- Perl_save_long
- Perl_save_mortalizesv
- Perl_save_nogv
- Perl_save_op
- Perl_save_re_context
- Perl_sv_2iv
- Perl_sv_2pv
- Perl_sv_2pv_nolen
- Perl_sv_2pvbyte_nolen
- Perl_sv_2pvutf8_nolen
- Perl_sv_2uv
- Perl_sv_catpvn
- Perl_sv_catpvn_mg
- Perl_sv_catsv
- Perl_sv_catsv_mg
- Perl_sv_force_normal
- Perl_sv_insert
- Perl_sv_iv
- Perl_sv_mortalcopy
- Perl_sv_nolocking
- Perl_sv_nounlocking
- Perl_sv_nv
- Perl_sv_pv
- Perl_sv_pvbyte
- Perl_sv_pvbyten
- Perl_sv_pvn
- Perl_sv_pvn_force
- Perl_sv_pvn_nomg
- Perl_sv_pvutf8
- Perl_sv_pvutf8n
- Perl_sv_setsv
- Perl_sv_taint
- Perl_sv_unref
- Perl_sv_usepvn
- Perl_sv_usepvn_mg
- Perl_sv_utf8_upgrade
- Perl_sv_uv
- Perl_to_uni_lower_lc
- Perl_to_uni_title_lc
- Perl_to_uni_upper_lc
- Perl_to_utf8_fold
- Perl_to_utf8_lower
- Perl_to_utf8_title
- Perl_to_utf8_upper
- Perl_unpack_str
- Perl_utf8_to_uvchr
- Perl_utf8_to_uvuni
- Perl_valid_utf8_to_uvuni
- );
-}
unless ($define{'PERL_NEED_APPCTX'}) {
++$skip{PL_appctx};
Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
{
dTHXs;
- int ret = 0;
va_list(arglist);
/* Easier to special case this here than in embed.pl. (Look at what it
#endif
va_start(arglist, format);
- ret = PerlIO_vprintf(stream, format, arglist);
- va_end(arglist);
- return ret;
+ return PerlIO_vprintf(stream, format, arglist);
}
int
{
dTHX;
va_list(arglist);
- int ret = 0;
#ifdef PERL_IMPLICIT_CONTEXT
PERL_ARGS_ASSERT_PRINTF_NOCONTEXT;
#endif
va_start(arglist, format);
- ret = PerlIO_vprintf(PerlIO_stdout(), format, arglist);
- va_end(arglist);
- return ret;
+ return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
}
#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
break;
case ':':
+ break;
case '/':
break;
case '[':
PERL_UNUSED_ARG(mg);
#endif
- TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
+ TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
return 0;
}
);
}
} else {
- sv_setsv(sv, PL_rs);
/* diag_listed_as: Setting $/ to %s reference is forbidden */
Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
*reftype == 'A' ? "n" : "", reftype);
break;
case '<':
{
- /* XXX $< currently silently ignores failures */
+ int rc = 0;
const Uid_t new_uid = SvUID(sv);
PL_delaymagic_uid = new_uid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETRUID
- PERL_UNUSED_RESULT(setruid(new_uid));
+ rc = setruid(new_uid);
#else
#ifdef HAS_SETREUID
- PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
+ rc = setreuid(new_uid, (Uid_t)-1);
#else
#ifdef HAS_SETRESUID
- PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
+ rc = setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
#else
if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
#ifdef PERL_DARWIN
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
if (new_uid != 0 && PerlProc_getuid() == 0)
- PERL_UNUSED_RESULT(PerlProc_setuid(0));
+ rc = PerlProc_setuid(0);
#endif
- PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
+ rc = PerlProc_setuid(new_uid);
} else {
Perl_croak(aTHX_ "setruid() not implemented");
}
#endif
#endif
#endif
+ /* XXX $< currently silently ignores failures */
+ PERL_UNUSED_VAR(rc);
break;
}
case '>':
{
- /* XXX $> currently silently ignores failures */
+ int rc = 0;
const Uid_t new_euid = SvUID(sv);
PL_delaymagic_euid = new_euid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETEUID
- PERL_UNUSED_RESULT(seteuid(new_euid));
+ rc = seteuid(new_euid);
#else
#ifdef HAS_SETREUID
- PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
+ rc = setreuid((Uid_t)-1, new_euid);
#else
#ifdef HAS_SETRESUID
- PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
+ rc = setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
#else
if (new_euid == PerlProc_getuid()) /* special case $> = $< */
- PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
+ rc = PerlProc_setuid(new_euid);
else {
Perl_croak(aTHX_ "seteuid() not implemented");
}
#endif
#endif
#endif
+ /* XXX $> currently silently ignores failures */
+ PERL_UNUSED_VAR(rc);
break;
}
case '(':
{
- /* XXX $( currently silently ignores failures */
+ int rc = 0;
const Gid_t new_gid = SvGID(sv);
PL_delaymagic_gid = new_gid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETRGID
- PERL_UNUSED_RESULT(setrgid(new_gid));
+ rc = setrgid(new_gid);
#else
#ifdef HAS_SETREGID
- PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
+ rc = setregid(new_gid, (Gid_t)-1);
#else
#ifdef HAS_SETRESGID
- PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
+ rc = setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
#else
if (new_gid == PerlProc_getegid()) /* special case $( = $) */
- PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
+ rc = PerlProc_setgid(new_gid);
else {
Perl_croak(aTHX_ "setrgid() not implemented");
}
#endif
#endif
#endif
+ /* XXX $( currently silently ignores failures */
+ PERL_UNUSED_VAR(rc);
break;
}
case ')':
{
- /* XXX $) currently silently ignores failures */
+ int rc = 0;
Gid_t new_egid;
#ifdef HAS_SETGROUPS
{
gary[i] = (Groups_t)Atol(p);
}
if (i)
- PERL_UNUSED_RESULT(setgroups(i, gary));
+ rc = setgroups(i, gary);
Safefree(gary);
}
#else /* HAS_SETGROUPS */
break; /* don't do magic till later */
}
#ifdef HAS_SETEGID
- PERL_UNUSED_RESULT(setegid(new_egid));
+ rc = setegid(new_egid);
#else
#ifdef HAS_SETREGID
- PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
+ rc = setregid((Gid_t)-1, new_egid);
#else
#ifdef HAS_SETRESGID
- PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
+ rc = setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
#else
if (new_egid == PerlProc_getgid()) /* special case $) = $( */
- PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
+ rc = PerlProc_setgid(new_egid);
else {
Perl_croak(aTHX_ "setegid() not implemented");
}
#endif
#endif
#endif
+ /* XXX $) currently silently ignores failures */
+ PERL_UNUSED_VAR(rc);
break;
}
case ':':
/* assumes get-magic and stringification have already occurred */
# define MgBYTEPOS_set(mg,sv,pv,off) ( \
assert_((mg)->mg_type == PERL_MAGIC_regex_global) \
- SvPOK(sv) && (!SvGMAGICAL(sv) || sv_only_taint_gmagic(sv)) \
+ SvPOK(sv) && !SvGMAGICAL(sv) \
? (mg)->mg_len = (off), (mg)->mg_flags |= MGf_BYTES \
: ((mg)->mg_len = DO_UTF8(sv) \
? (SSize_t)utf8_length((U8 *)(pv), (U8 *)(pv)+(off)) \
/* for s/// and tr///, last element in list is the replacement; pop it */
- /* If we have a syntax error causing tokens to be popped and the parser
- to see PMFUNC '(' expr ')' with no commas in it; e.g., s/${<>{})//,
- then expr will not be of type OP_LIST, there being no repl. */
- if ((is_trans || o->op_type == OP_SUBST) && expr->op_type == OP_LIST) {
+ if (is_trans || o->op_type == OP_SUBST) {
OP* kid;
repl = cLISTOPx(expr)->op_last;
kid = cLISTOPx(expr)->op_first;
* were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
* that isn't required now. Note that we have to be pretty
* confident that nothing used that CV's pad while the
- * regex was parsed, except maybe op targets for \Q etc.
- * If there were any op targets, though, they should have
- * been stolen by constant folding.
- */
-#ifdef DEBUGGING
- PADOFFSET i = 0;
- assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
- while (++i <= AvFILLp(PL_comppad)) {
- assert(!PL_curpad[i]);
- }
-#endif
+ * regex was parsed */
+ assert(AvFILLp(PL_comppad) == 0); /* just @_ */
/* But we know that one op is using this CV's slab. */
cv_forget_slab(PL_compcv);
LEAVE_SCOPE(floor);
*/
SvREFCNT_inc_simple_void(PL_compcv);
- CvLVALUE_on(PL_compcv);
/* these lines are just an unrolled newANONATTRSUB */
expr = newSVOP(OP_ANONCODE, 0,
MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
SVOP * const kid = (SVOP*)cUNOPo->op_first;
assert(kid);
- if (o->op_type == OP_ENTERTRY) {
+ if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
#ifdef PERL_MAD
OP* const oldo = o;
STATIC void
S_null_listop_in_list_context(pTHX_ OP *o)
{
+ OP *kid;
+
PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
/* This is an OP_LIST in list context. That means we
* can ditch the OP_LIST and the OP_PUSHMARK within. */
+ kid = cLISTOPo->op_first;
+ /* Find the end of the chain of OPs executed within the OP_LIST. */
+ while (kid->op_next != o)
+ kid = kid->op_next;
+
+ kid->op_next = o->op_next; /* patch list out of exec chain */
op_null(cUNOPo->op_first); /* NULL the pushmark */
op_null(o); /* NULL the list */
}
* altering the basic op_first/op_sibling layout. */
kid = kLISTOP->op_first;
assert(
- (kid->op_type == OP_NULL
- && ( kid->op_targ == OP_NEXTSTATE
- || kid->op_targ == OP_DBSTATE ))
+ (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
|| kid->op_type == OP_STUB
|| kid->op_type == OP_ENTER);
nullop->op_next = kLISTOP->op_next;
XOPe_xop_name = XOPf_xop_name,
XOPe_xop_desc = XOPf_xop_desc,
XOPe_xop_class = XOPf_xop_class,
- XOPe_xop_peep = XOPf_xop_peep
+ XOPe_xop_peep = XOPf_xop_peep,
} xop_flags_enum;
#define XOPd_xop_name PL_op_name[OP_CUSTOM]
to the registree to ensure it is accurate. The value returned will be
one of the OA_* constants from op.h.
-=for apidoc Am|bool|OP_TYPE_IS|OP *o|Optype type
+=for apidoc Am|bool|OP_TYPE_IS|OP *o, Optype type
Returns true if the given OP is not a NULL pointer
and if it is of the given type.
as well as C<OP_TYPE_IS_NN> and C<OP_TYPE_ISNT_NN> which elide
the NULL pointer check.
-=for apidoc Am|bool|OP_TYPE_IS_OR_WAS|OP *o|Optype type
+=for apidoc Am|bool|OP_TYPE_IS_OR_WAS|OP *o, Optype type
Returns true if the given OP is not a NULL pointer and
if it is of the given type or used to be before being
replaced by an OP of type OP_NULL.
AV which is @_. Other entries are storage for variables and op targets.
Iterating over the PADNAMELIST iterates over all possible pad
-items. Pad slots for targets (SVs_PADTMP)
-and GVs end up having &PL_sv_undef
+items. Pad slots for targets (SVs_PADTMP) and GVs end up having &PL_sv_no
"names", while slots for constants have &PL_sv_no "names" (see
pad_alloc()). That &PL_sv_no is used is an implementation detail subject
to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
if (is_utf8)
flags |= padadd_UTF8_NAME;
- else {
+ else
flags &= ~padadd_UTF8_NAME;
- SAVEFREEPV(namepv);
- }
}
offset = pad_findlex(namepv, namelen, flags,
=for apidoc m|SV *|PAD_SETSV |PADOFFSET po|SV* sv
Set the slot at offset C<po> in the current pad to C<sv>
-=for apidoc m|SV *|PAD_SV |PADOFFSET po
+=for apidoc m|void|PAD_SV |PADOFFSET po
Get the value at offset C<po> in the current pad
=for apidoc m|SV *|PAD_SVl |PADOFFSET po
* exactly on the third column */
#define PERL_REVISION 5 /* age */
-#define PERL_VERSION 20 /* epoch */
-#define PERL_SUBVERSION 3 /* generation */
+#define PERL_VERSION 21 /* epoch */
+#define PERL_SUBVERSION 0 /* generation */
/* The following numbers describe the earliest compatible version of
Perl ("compatibility" here being defined as sufficient binary/API
changing them should not be necessary.
*/
#define PERL_API_REVISION 5
-#define PERL_API_VERSION 20
+#define PERL_API_VERSION 21
#define PERL_API_SUBVERSION 0
/*
XXX Note: The selection of non-default Configure options, such
/* Initial space prevents this variable from being inserted in config.sh */
# define LOCAL_PATCH_COUNT \
- ((int)(C_ARRAY_LENGTH(local_patches)-2))
+ ((int)(sizeof(local_patches)/sizeof(local_patches[0])-2))
/* the old terms of reference, add them only when explicitly included */
#define PATCHLEVEL PERL_VERSION
msg.msg_name = NULL;
msg.msg_namelen = 0;
msg.msg_iov = vec;
- msg.msg_iovlen = C_ARRAY_LENGTH(vec);
+ msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
vec[0].iov_base = (void*)⌖
vec[0].iov_len = sizeof(target);
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
- /* s points to static memory in getenv(), which may be overwritten at
- * any time; use a mortal copy instead */
- s = SvPVX(sv_2mortal(newSVpv(s, 0)));
-
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
/*
=for apidoc p||eval_pv
-Tells Perl to C<eval> the given string in scalar context and return an SV* result.
+Tells Perl to C<eval> the given string and return an SV* result.
=cut
*/
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2015, Larry Wall\n");
+ "\n\nCopyright 1987-2014, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
# define PERL_UNUSED_CONTEXT
#endif
-/* gcc (-ansi) -pedantic doesn't allow gcc statement expressions,
- * g++ allows them but seems to have problems with them
- * (insane errors ensue).
- * g++ does not give insane errors now (RMB 2008-01-30, gcc 4.2.2).
- */
-#if defined(PERL_GCC_PEDANTIC) || \
- (defined(__GNUC__) && defined(__cplusplus) && \
- ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2))))
-# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
-# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
-# endif
-#endif
-
-/* Use PERL_UNUSED_RESULT() to suppress the warnings about unused results
- * of function calls, e.g. PERL_UNUSED_RESULT(foo(a, b)).
- *
- * The main reason for this is that the combination of gcc -Wunused-result
- * (part of -Wall) and the __attribute__((warn_unused_result)) cannot
- * be silenced with casting to void. This causes trouble when the system
- * header files use the attribute.
- *
- * Use PERL_UNUSED_RESULT sparingly, though, since usually the warning
- * is there for a good reason: you might lose success/failure information,
- * or leak resources, or changes in resources.
- *
- * But sometimes you just want to ignore the return value, e.g. on
- * codepaths soon ending up in abort, or in "best effort" attempts,
- * or in situations where there is no good way to handle failures.
- *
- * Sometimes PERL_UNUSED_RESULT might not be the most natural way:
- * another possibility is that you can capture the return value
- * and use PERL_UNUSED_VAR on that.
- *
- * The __typeof__() is used instead of typeof() since typeof() is not
- * available under strict C89, and because of compilers masquerading
- * as gcc (clang and icc), we want exactly the gcc extension
- * __typeof__ and nothing else.
- */
-#ifndef PERL_UNUSED_RESULT
-# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
-# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
-# else
-# define PERL_UNUSED_RESULT(v) ((void)(v))
-# endif
-#endif
-
/* on gcc (and clang), specify that a warning should be temporarily
* ignored; e.g.
*
# endif
#endif
+/* gcc (-ansi) -pedantic doesn't allow gcc statement expressions,
+ * g++ allows them but seems to have problems with them
+ * (insane errors ensue).
+ * g++ does not give insane errors now (RMB 2008-01-30, gcc 4.2.2).
+ */
+#if defined(PERL_GCC_PEDANTIC) || \
+ (defined(__GNUC__) && defined(__cplusplus) && \
+ ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2))))
+# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# endif
+#endif
+
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
# ifndef PERL_USE_GCC_BRACE_GROUPS
# define PERL_USE_GCC_BRACE_GROUPS
# endif
#endif
-/* EVC 4 SDK headers includes a bad definition of MB_CUR_MAX in stdlib.h
- which is included from stdarg.h. Bad definition not present in SD 2008
- SDK headers. wince.h is not yet included, so we cant fix this from there
- since by then MB_CUR_MAX will be defined from stdlib.h.
- cewchar.h includes a correct definition of MB_CUR_MAX and it is copied here
- since cewchar.h can't be included this early */
-#if defined(UNDER_CE) && (_MSC_VER < 1300)
-# define MB_CUR_MAX 1
-#endif
#ifdef I_STDARG
# include <stdarg.h>
#else
# define WIN32SCK_IS_STDSCK /* don't pull in custom wsock layer */
#endif
+/* In Tru64 use the 4.4BSD struct msghdr, not the 4.3 one.
+ * This is important for using IPv6.
+ * For OSF/1 3.2, however, defining _SOCKADDR_LEN would be
+ * a bad idea since it breaks send() and recv(). */
+#if defined(__osf__) && defined(__alpha) && !defined(_SOCKADDR_LEN) && !defined(DEC_OSF1_3_X)
+# define _SOCKADDR_LEN
+#endif
+
#if defined(HAS_SOCKET) && !defined(WIN32) /* WIN32 handles sockets via win32.h */
# include <sys/socket.h>
# if defined(USE_SOCKS) && defined(I_SOCKS)
# include <ieeefp.h>
#endif
-#ifdef USING_MSVC6
-/* VC6 has broken NaN semantics: NaN == NaN returns true instead of false,
- * and for example NaN < IV_MIN. */
-# define NAN_COMPARE_BROKEN
-#endif
-#if defined(__DECC) && defined(__osf__)
-/* Also Tru64 cc has broken NaN comparisons. */
-# define NAN_COMPARE_BROKEN
-#endif
-
#ifdef USE_LONG_DOUBLE
# ifdef I_SUNMATH
# include <sunmath.h>
# ifdef PERL_GLOBAL_STRUCT
" PERL_GLOBAL_STRUCT"
# endif
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
- " PERL_GLOBAL_STRUCT_PRIVATE"
-# endif
# ifdef PERL_IMPLICIT_CONTEXT
" PERL_IMPLICIT_CONTEXT"
# endif
#define PERLDB_SAVESRC_NOSUBS (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_NOSUBS))
#define PERLDB_SAVESRC_INVALID (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_INVALID))
-/*
-
-=head1 Locale-related functions and macros
-
-=for apidoc sync_locale
-
-Changing the program's locale should be avoided by XS code. Nevertheless,
-certain non-Perl libraries called from XS, such as C<Gtk> do so. When this
-happens, Perl needs to be told that the locale has changed. Use this macro
-to do so, before returning to Perl code.
-
-=cut
-*/
-
-/* Temporary for maint. Is a function in 5.21 */
-#define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), \
- new_collate(setlocale(LC_COLLATE, NULL)), \
- set_numeric_local(), \
- new_numeric(setlocale(LC_NUMERIC, NULL)))
-
#ifdef USE_LOCALE_NUMERIC
/* Returns TRUE if the plain locale pragma without a parameter is in effect
}
}
if (PL_perlio_debug_fd > 0) {
+ int rc = 0;
#ifdef USE_ITHREADS
const char * const s = CopFILE(PL_curcop);
/* Use fixed buffer as sv_catpvf etc. needs SVs */
char buffer[1024];
const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
- PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
+ rc = PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
#else
const char *s = CopFILE(PL_curcop);
STRLEN len;
Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
s = SvPV_const(sv, len);
- PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
+ rc = PerlLIO_write(PL_perlio_debug_fd, s, len);
SvREFCNT_dec(sv);
#endif
+ /* silently ignore failures */
+ PERL_UNUSED_VAR(rc);
}
va_end(ap);
}
}
if (!PerlIOValid(f)) {
if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
- PerlLIO_close(fd);
return NULL;
}
}
PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
return f;
}
- PerlLIO_close(fd);
}
return NULL;
}
}
return f;
}
- PerlLIO_close(fd);
}
}
return NULL;
va_list apc;
Perl_va_copy(ap, apc);
sv = vnewSVpvf(fmt, &apc);
- va_end(apc);
#else
sv = vnewSVpvf(fmt, &ap);
#endif
* 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.20.3" /**/
-#define PRIVLIB_EXP "/sys/lib/perl/5.20.3" /**/
+#define PRIVLIB "/sys/lib/perl/5.21.0" /**/
+#define PRIVLIB_EXP "/sys/lib/perl/5.21.0" /**/
/* 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.20.3/site_perl" /**/
-#define SITELIB_EXP "/sys/lib/perl/5.20.3/site_perl" /**/
-#define SITELIB_STEM "/sys/lib/perl/5.20.3/site_perl" /**/
+#define SITELIB "/sys/lib/perl/5.21.0/site_perl" /**/
+#define SITELIB_EXP "/sys/lib/perl/5.21.0/site_perl" /**/
+#define SITELIB_STEM "/sys/lib/perl/5.21.0/site_perl" /**/
/* Size_t_size:
* This symbol holds the size of a Size_t in bytes.
aphostname='/bin/uname -n'
api_revision='5'
api_subversion='0'
-api_version='20'
-api_versionstring='5.20.0'
+api_version='21'
+api_versionstring='5.21.0'
ar='ar'
-archlib='/sys/lib/perl5/5.20.3/386'
-archlibexp='/sys/lib/perl5/5.20.3/386'
+archlib='/sys/lib/perl5/5.21.0/386'
+archlibexp='/sys/lib/perl5/5.21.0/386'
archname64=''
archname='386'
archobjs=''
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='/sys/lib/perl/5.20.3/386'
+installarchlib='/sys/lib/perl/5.21.0/386'
installbin='/usr/bin'
installman1dir='/sys/man/1pub'
installman3dir='/sys/man/2pub'
installprefix='/usr'
installprefixexp='/usr'
-installprivlib='/sys/lib/perl/5.20.3'
+installprivlib='/sys/lib/perl/5.21.0'
installscript='/usr/bin'
-installsitearch='/sys/lib/perl/5.20.3/site_perl/386'
+installsitearch='/sys/lib/perl/5.21.0/site_perl/386'
installsitebin='/usr/bin'
-installsitelib='/sys/lib/perl/5.20.3/site_perl'
+installsitelib='/sys/lib/perl/5.21.0/site_perl'
installstyle='lib/perl5'
installusrbinperl='undef'
installvendorarch=''
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/sys/lib/perl/5.20.3'
-privlibexp='/sys/lib/perl/5.20.3'
+privlib='/sys/lib/perl/5.21.0'
+privlibexp='/sys/lib/perl/5.21.0'
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.20.3/site_perl/386'
+sitearch='/sys/lib/perl/5.21.0/site_perl/386'
sitearchexp='/sys/lib/perl/site_perl/386'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
-sitelib='/sys/lib/perl/5.20.3/site_perl'
-sitelib_stem='/sys/lib/perl/5.20.3/site_perl'
-sitelibexp='/sys/lib/perl/5.20.3/site_perl'
+sitelib='/sys/lib/perl/5.21.0/site_perl'
+sitelib_stem='/sys/lib/perl/5.21.0/site_perl'
+sitelibexp='/sys/lib/perl/5.21.0/site_perl'
siteprefix='/usr'
siteprefixexp='/usr'
sizesize='4'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='3'
+subversion='0'
sysman='/sys/man/1pub'
tail=''
tar=''
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='5.20.3'
-version_patchlevel_string='version 20 subversion 3'
+version='5.21.0'
+version_patchlevel_string='version 21 subversion 0'
versiononly='undef'
vi=''
xlibpth=''
config_args=''
config_argc=0
PERL_REVISION=5
-PERL_VERSION=20
-PERL_SUBVERSION=3
+PERL_VERSION=21
+PERL_SUBVERSION=0
PERL_API_REVISION=5
-PERL_API_VERSION=20
+PERL_API_VERSION=21
PERL_API_SUBVERSION=0
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
podnames = perl perlbook perldata perldebtut perldiag perldsc perlform perlfunc perlipc perllexwarn perllol perlmod perlmodlib perlmodinstall perlnewmod perlop perlootut perlopentut perlpacktut perlpod perlport perlrequick perlretut perlref perlreftut perlrequick perlrun perlsec perlstyle perlsub perlsyn perltie perltrap perlutil perlunifaq perluniintro perlvar
faqpodnames = perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5 perlfaq6 perlfaq7 perlfaq8 perlfaq9
-advpodnames = perlapi perlapio perlcall perlclib perlcompile perldebguts perldbmfilter perldebug perldelta perldiag perlebcdic perlembed perlfilter perlfork perlguts perlhack perlintern perliol perllocale perlnumber perlobj perlpodspec perlre perlthrtut perltodo perlunicode perlunicook perlxs perlxs perlxstut
+advpodnames = perlapi perlapio perlcall perlclib perlcompile perldebguts perldbmfilter perldebug perldelta perldiag perlebcdic perlembed perlfilter perlfork perlguts perlhack perlintern perliol perllocale perlnumber perlobj perlpodspec perlre perlthrtut perltodo perlunicode perlxs perlxs perlxstut
archpodnames = perlaix perlamiga perlbeos perlbs2000 perlce perlcygwin perldgux perldos perlfreebsd perlhpux perlhurd perlirix perlmacos perlmpeix perlnetware perlos2 perlos390 perlos400 perlplan9 perlqnx perlsolaris perltru64 perlvms perlvos perlwin32
histpods = perl5004delta perl5005delta perl561delta perl56delta perl570delta perl571delta perl572delta perl573delta perl58delta perlhist
/roffitall
# generated
-/perl5203delta.pod
+/perl5210delta.pod
/perlapi.pod
/perlintern.pod
*.html
perllocale Perl locale support
perluniintro Perl Unicode introduction
perlunicode Perl Unicode support
- perlunicook Perl Unicode cookbook
perlunifaq Perl Unicode FAQ
perluniprops Index of Unicode properties in Perl
perlunitut Perl Unicode tutorial
perlhist Perl history records
perldelta Perl changes since previous version
- perl5202delta Perl changes in version 5.20.2
- perl5201delta Perl changes in version 5.20.1
- perl5200delta Perl changes in version 5.20.0
- perl5184delta Perl changes in version 5.18.4
+ perl5200delta Perl changes in version 5.20.0
perl5182delta Perl changes in version 5.18.2
perl5181delta Perl changes in version 5.18.1
perl5180delta Perl changes in version 5.18.0
- perl5163delta Perl changes in version 5.16.3
- perl5162delta Perl changes in version 5.16.2
perl5161delta Perl changes in version 5.16.1
+ perl5162delta Perl changes in version 5.16.2
+ perl5163delta Perl changes in version 5.16.3
perl5160delta Perl changes in version 5.16.0
perl5144delta Perl changes in version 5.14.4
perl5143delta Perl changes in version 5.14.3
+++ /dev/null
-=encoding utf8
-
-=head1 NAME
-
-perl5184delta - what is new for perl v5.18.4
-
-=head1 DESCRIPTION
-
-This document describes differences between the 5.18.4 release and the 5.18.2
-release. B<Please note:> This document ignores perl 5.18.3, a broken release
-which existed for a few hours only.
-
-If you are upgrading from an earlier release such as 5.18.1, first read
-L<perl5182delta>, which describes differences between 5.18.1 and 5.18.2.
-
-=head1 Modules and Pragmata
-
-=head2 Updated Modules and Pragmata
-
-=over 4
-
-=item *
-
-L<Digest::SHA> has been upgraded from 5.84_01 to 5.84_02.
-
-=item *
-
-L<perl5db.pl> has been upgraded from version 1.39_10 to 1.39_11.
-
-This fixes a crash in tab completion, where available. [perl #120827] Also,
-filehandle information is properly reset after a pager is run. [perl #121456]
-
-=back
-
-=head1 Platform Support
-
-=head2 Platform-Specific Notes
-
-=over 4
-
-=item Win32
-
-=over 4
-
-=item *
-
-Introduced by
-L<perl #113536|https://rt.perl.org/Public/Bug/Display.html?id=113536>, a memory
-leak on every call to C<system> and backticks (C< `` >), on most Win32 Perls
-starting from 5.18.0 has been fixed. The memory leak only occurred if you
-enabled psuedo-fork in your build of Win32 Perl, and were running that build on
-Server 2003 R2 or newer OS. The leak does not appear on WinXP SP3.
-[L<perl #121676|https://rt.perl.org/Public/Bug/Display.html?id=121676>]
-
-=back
-
-=back
-
-=head1 Selected Bug Fixes
-
-=over 4
-
-=item *
-
-The debugger now properly resets filehandles as needed. [perl #121456]
-
-=item *
-
-A segfault in Digest::SHA has been addressed. [perl #121421]
-
-=item *
-
-perl can again be built with USE_64_BIT_INT, with Visual C 2003, 32 bit.
-[perl #120925]
-
-=item *
-
-A leading { (brace) in formats is properly parsed again. [perl #119973]
-
-=item *
-
-Copy the values used to perturb hash iteration when cloning an
-interpreter. This was fairly harmless but caused C<valgrind> to
-complain. [perl #121336]
-
-=item *
-
-In Perl v5.18 C<undef *_; goto &sub> and C<local *_; goto &sub> started
-crashing. This has been fixed. [perl #119949]
-
-=back
-
-=head1 Acknowledgements
-
-Perl 5.18.4 represents approximately 9 months of development since Perl 5.18.2
-and contains approximately 2,000 lines of changes across 53 files from 13
-authors.
-
-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.18.4:
-
-Daniel Dragan, David Mitchell, Doug Bell, Father Chrysostomos, Hiroo Hayashi,
-James E Keenan, Karl Williamson, Mark Shelor, Ricardo Signes, Shlomi Fish,
-Smylers, Steve Hay, Tony Cook.
-
-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
-http://rt.perl.org/perlbug/ . There may also be information at
-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 please send it
-to perl5-security-report@perl.org. This points to a closed subscription
-unarchived mailing list, which includes all the core committers, who will be
-able to help assess the impact of issues, figure out a resolution, and help
-co-ordinate the release of patches to mitigate or fix the problem across all
-platforms on which Perl is supported. Please only use this address for
-security issues in the Perl core, not for modules independently distributed on
-CPAN.
-
-=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
-
+++ /dev/null
-=encoding utf8
-
-=head1 NAME
-
-perl5201delta - what is new for perl v5.20.1
-
-=head1 DESCRIPTION
-
-This document describes differences between the 5.20.0 release and the 5.20.1
-release.
-
-If you are upgrading from an earlier release such as 5.18.0, first read
-L<perl5200delta>, which describes differences between 5.18.0 and 5.20.0.
-
-=head1 Incompatible Changes
-
-There are no changes intentionally incompatible with 5.20.0. If any exist,
-they are bugs, and we request that you submit a report. See L</Reporting Bugs>
-below.
-
-=head1 Performance Enhancements
-
-=over 4
-
-=item *
-
-An optimization to avoid problems with COW and deliberately overallocated PVs
-has been disabled because it interfered with another, more important,
-optimization, causing a slowdown on some platforms.
-L<[perl #121975]|https://rt.perl.org/Ticket/Display.html?id=121975>
-
-=item *
-
-Returning a string from a lexical variable could be slow in some cases. This
-has now been fixed.
-L<[perl #121977]|https://rt.perl.org/Ticket/Display.html?id=121977>
-
-=back
-
-=head1 Modules and Pragmata
-
-=head2 Updated Modules and Pragmata
-
-=over 4
-
-=item *
-
-L<Config::Perl::V> has been upgraded from version 0.20 to 0.22.
-
-The list of Perl versions covered has been updated and some flaws in the
-parsing have been fixed.
-
-=item *
-
-L<Exporter> has been upgraded from version 5.70 to 5.71.
-
-Illegal POD syntax in the documentation has been corrected.
-
-=item *
-
-L<ExtUtils::CBuilder> has been upgraded from version 0.280216 to 0.280217.
-
-Android builds now link to both B<-lperl> and C<$Config::Config{perllibs}>.
-
-=item *
-
-L<File::Copy> has been upgraded from version 2.29 to 2.30.
-
-The documentation now notes that C<copy> will not overwrite read-only files.
-
-=item *
-
-L<Module::CoreList> has been upgraded from version 3.11 to 5.020001.
-
-The list of Perl versions covered has been updated.
-
-=item *
-
-The PathTools module collection has been upgraded from version 3.47 to 3.48.
-
-Fallbacks are now in place when cross-compiling for Android and
-C<$Config::Config{sh}> is not yet defined.
-L<[perl #121963]|https://rt.perl.org/Ticket/Display.html?id=121963>
-
-=item *
-
-L<PerlIO::via> has been upgraded from version 0.14 to 0.15.
-
-A minor portability improvement has been made to the XS implementation.
-
-=item *
-
-L<Unicode::UCD> has been upgraded from version 0.57 to 0.58.
-
-The documentation includes many clarifications and fixes.
-
-=item *
-
-L<utf8> has been upgraded from version 1.13 to 1.13_01.
-
-The documentation has some minor formatting improvements.
-
-=item *
-
-L<version> has been upgraded from version 0.9908 to 0.9909.
-
-External libraries and Perl may have different ideas of what the locale is.
-This is problematic when parsing version strings if the locale's numeric
-separator has been changed. Version parsing has been patched to ensure it
-handles the locales correctly.
-L<[perl #121930]|https://rt.perl.org/Ticket/Display.html?id=121930>
-
-=back
-
-=head1 Documentation
-
-=head2 Changes to Existing Documentation
-
-=head3 L<perlapi>
-
-=over 4
-
-=item *
-
-C<av_len> - Emphasize that this returns the highest index in the array, not the
-size of the array.
-L<[perl #120386]|https://rt.perl.org/Ticket/Display.html?id=120386>
-
-=item *
-
-Note that C<SvSetSV> doesn't do set magic.
-
-=item *
-
-C<sv_usepvn_flags> - Fix documentation to mention the use of C<NewX> instead of
-C<malloc>.
-L<[perl #121869]|https://rt.perl.org/Ticket/Display.html?id=121869>
-
-=item *
-
-Clarify where C<NUL> may be embedded or is required to terminate a string.
-
-=back
-
-=head3 L<perlfunc>
-
-=over 4
-
-=item *
-
-Clarify the meaning of C<-B> and C<-T>.
-
-=item *
-
-C<-l> now notes that it will return false if symlinks aren't supported by the
-file system.
-L<[perl #121523]|https://rt.perl.org/Ticket/Display.html?id=121523>
-
-=item *
-
-Note that C<each>, C<keys> and C<values> may produce different orderings for
-tied hashes compared to other perl hashes.
-L<[perl #121404]|https://rt.perl.org/Ticket/Display.html?id=121404>
-
-=item *
-
-Note that C<exec LIST> and C<system LIST> may fall back to the shell on Win32.
-Only C<exec PROGRAM LIST> and C<system PROGRAM LIST> indirect object syntax
-will reliably avoid using the shell. This has also been noted in L<perlport>.
-L<[perl #122046]|https://rt.perl.org/Ticket/Display.html?id=122046>
-
-=item *
-
-Clarify the meaning of C<our>.
-L<[perl #122132]|https://rt.perl.org/Ticket/Display.html?id=122132>
-
-=back
-
-=head3 L<perlguts>
-
-=over 4
-
-=item *
-
-Explain various ways of modifying an existing SV's buffer.
-L<[perl #116925]|https://rt.perl.org/Ticket/Display.html?id=116925>
-
-=back
-
-=head3 L<perlpolicy>
-
-=over 4
-
-=item *
-
-We now have a code of conduct for the I<< p5p >> mailing list, as documented in
-L<< perlpolicy/STANDARDS OF CONDUCT >>.
-
-=back
-
-=head3 L<perlre>
-
-=over 4
-
-=item *
-
-The C</x> modifier has been clarified to note that comments cannot be continued
-onto the next line by escaping them.
-
-=back
-
-=head3 L<perlsyn>
-
-=over 4
-
-=item *
-
-Mention the use of empty conditionals in C<for>/C<while> loops for infinite
-loops.
-
-=back
-
-=head3 L<perlxs>
-
-=over 4
-
-=item *
-
-Added a discussion of locale issues in XS code.
-
-=back
-
-=head1 Diagnostics
-
-The following additions or changes have been made to diagnostic output,
-including warnings and fatal error messages. For the complete list of
-diagnostic messages, see L<perldiag>.
-
-=head2 Changes to Existing Diagnostics
-
-=over 4
-
-=item *
-
-L<Variable length lookbehind not implemented in regex mE<sol>%sE<sol>|perldiag/"Variable length lookbehind not implemented in regex m/%s/">
-
-Information about Unicode behaviour has been added.
-
-=back
-
-=head1 Configuration and Compilation
-
-=over 4
-
-=item *
-
-Building Perl no longer writes to the source tree when configured with
-F<Configure>'s B<-Dmksymlinks> option.
-L<[perl #121585]|https://rt.perl.org/Ticket/Display.html?id=121585>
-
-=back
-
-=head1 Platform Support
-
-=head2 Platform-Specific Notes
-
-=over 4
-
-=item Android
-
-Build support has been improved for cross-compiling in general and for Android
-in particular.
-
-=item OpenBSD
-
-Corrected architectures and version numbers used in configuration hints when
-building Perl.
-
-=item Solaris
-
-B<c99> options have been cleaned up, hints look for B<solstudio> as well as
-B<SUNWspro>, and support for native C<setenv> has been added.
-
-=item VMS
-
-An old bug in feature checking, mainly affecting pre-7.3 systems, has been
-fixed.
-
-=item Windows
-
-C<%I64d> is now being used instead of C<%lld> for MinGW.
-
-=back
-
-=head1 Internal Changes
-
-=over 4
-
-=item *
-
-Added L<perlapi/sync_locale>.
-Changing the program's locale should be avoided by XS code. Nevertheless,
-certain non-Perl libraries called from XS, such as C<Gtk> do so. When this
-happens, Perl needs to be told that the locale has changed. Use this function
-to do so, before returning to Perl.
-
-=back
-
-=head1 Selected Bug Fixes
-
-=over 4
-
-=item *
-
-A bug has been fixed where zero-length assertions and code blocks inside of a
-regex could cause C<pos> to see an incorrect value.
-L<[perl #122460]|https://rt.perl.org/Ticket/Display.html?id=122460>
-
-=item *
-
-Using C<s///e> on tainted utf8 strings could issue bogus "Malformed UTF-8
-character (unexpected end of string)" warnings. This has now been fixed.
-L<[perl #122148]|https://rt.perl.org/Ticket/Display.html?id=122148>
-
-=item *
-
-C<system> and friends should now work properly on more Android builds.
-
-Due to an oversight, the value specified through B<-Dtargetsh> to F<Configure>
-would end up being ignored by some of the build process. This caused perls
-cross-compiled for Android to end up with defective versions of C<system>,
-C<exec> and backticks: the commands would end up looking for F</bin/sh> instead
-of F</system/bin/sh>, and so would fail for the vast majority of devices,
-leaving C<$!> as C<ENOENT>.
-
-=item *
-
-Many issues have been detected by L<Coverity|http://www.coverity.com/> and
-fixed.
-
-=back
-
-=head1 Acknowledgements
-
-Perl 5.20.1 represents approximately 4 months of development since Perl 5.20.0
-and contains approximately 12,000 lines of changes across 170 files from 36
-authors.
-
-Excluding auto-generated files, documentation and release tools, there were
-approximately 2,600 lines of changes to 110 .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.20.1:
-
-Aaron Crane, Abigail, Alberto Simões, Alexandr Ciornii, Alexandre (Midnite)
-Jousset, Andrew Fresh, Andy Dougherty, Brian Fraser, Chris 'BinGOs' Williams,
-Craig A. Berry, Daniel Dragan, David Golden, David Mitchell, H.Merijn Brand,
-James E Keenan, Jan Dubois, Jarkko Hietaniemi, John Peacock, kafka, Karen
-Etheridge, Karl Williamson, Lukas Mai, Matthew Horsfall, Michael Bunk, Peter
-Martini, Rafael Garcia-Suarez, Reini Urban, Ricardo Signes, Shirakata Kentaro,
-Smylers, Steve Hay, Thomas Sibley, Todd Rinaldo, Tony Cook, Vladimir Marek,
-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
-https://rt.perl.org/ . There may also be information at 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 please send it
-to perl5-security-report@perl.org. This points to a closed subscription
-unarchived mailing list, which includes all the core committers, who will be
-able to help assess the impact of issues, figure out a resolution, and help
-co-ordinate the release of patches to mitigate or fix the problem across all
-platforms on which Perl is supported. Please only use this address for
-security issues in the Perl core, not for modules independently distributed on
-CPAN.
-
-=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
+++ /dev/null
-=encoding utf8
-
-=head1 NAME
-
-perl5202delta - what is new for perl v5.20.2
-
-=head1 DESCRIPTION
-
-This document describes differences between the 5.20.1 release and the 5.20.2
-release.
-
-If you are upgrading from an earlier release such as 5.20.0, first read
-L<perl5201delta>, which describes differences between 5.20.0 and 5.20.1.
-
-=head1 Incompatible Changes
-
-There are no changes intentionally incompatible with 5.20.1. If any exist,
-they are bugs, and we request that you submit a report. See L</Reporting Bugs>
-below.
-
-=head1 Modules and Pragmata
-
-=head2 Updated Modules and Pragmata
-
-=over 4
-
-=item *
-
-L<attributes> has been upgraded from version 0.22 to 0.23.
-
-The usage of C<memEQs> in the XS has been corrected.
-L<[perl #122701]|https://rt.perl.org/Ticket/Display.html?id=122701>
-
-=item *
-
-L<Data::Dumper> has been upgraded from version 2.151 to 2.151_01.
-
-Fixes CVE-2014-4330 by adding a configuration variable/option to limit
-recursion when dumping deep data structures.
-
-=item *
-
-L<Errno> has been upgraded from version 1.20_03 to 1.20_05.
-
-Warnings when building the XS on Windows with the Visual C++ compiler are now
-avoided.
-
-=item *
-
-L<feature> has been upgraded from version 1.36 to 1.36_01.
-
-The C<postderef> feature has now been documented. This feature was actually
-added in Perl 5.20.0 but was accidentally omitted from the feature
-documentation until now.
-
-=item *
-
-L<IO::Socket> has been upgraded from version 1.37 to 1.38.
-
-Document the limitations of the connected() method.
-L<[perl #123096]|https://rt.perl.org/Ticket/Display.html?id=123096>
-
-=item *
-
-L<Module::CoreList> has been upgraded from version 5.020001 to 5.20150214.
-
-The list of Perl versions covered has been updated.
-
-=item *
-
-PathTools has been upgraded from version 3.48 to 3.48_01.
-
-A warning from the B<gcc> compiler is now avoided when building the XS.
-
-=item *
-
-L<PerlIO::scalar> has been upgraded from version 0.18 to 0.18_01.
-
-Reading from a position well past the end of the scalar now correctly returns
-end of file.
-L<[perl #123443]|https://rt.perl.org/Ticket/Display.html?id=123443>
-
-Seeking to a negative position still fails, but no longer leaves the file
-position set to a negation location.
-
-C<eof()> on a C<PerlIO::scalar> handle now properly returns true when the file
-position is past the 2GB mark on 32-bit systems.
-
-=item *
-
-L<Storable> has been upgraded from version 2.49 to 2.49_01.
-
-Minor grammatical change to the documentation only.
-
-=item *
-
-L<VMS::DCLsym> has been upgraded from version 1.05 to 1.05_01.
-
-Minor formatting change to the documentation only.
-
-=item *
-
-L<VMS::Stdio> has been upgraded from version 2.4 to 2.41.
-
-Minor formatting change to the documentation only.
-
-=back
-
-=head1 Documentation
-
-=head2 New Documentation
-
-=head3 L<perlunicook>
-
-This document, by Tom Christiansen, provides examples of handling Unicode in
-Perl.
-
-=head2 Changes to Existing Documentation
-
-=head3 L<perlexperiment>
-
-=over 4
-
-=item *
-
-Added reference to subroutine signatures. This feature was actually added in
-Perl 5.20.0 but was accidentally omitted from the experimental feature
-documentation until now.
-
-=back
-
-=head3 L<perlpolicy>
-
-=over 4
-
-=item *
-
-The process whereby features may graduate from experimental status has now been
-formally documented.
-
-=back
-
-=head3 L<perlsyn>
-
-=over 4
-
-=item *
-
-An ambiguity in the documentation of the ellipsis statement has been corrected.
-L<[perl #122661]|https://rt.perl.org/Ticket/Display.html?id=122661>
-
-=back
-
-=head1 Diagnostics
-
-The following additions or changes have been made to diagnostic output,
-including warnings and fatal error messages. For the complete list of
-diagnostic messages, see L<perldiag>.
-
-=head2 Changes to Existing Diagnostics
-
-=over 4
-
-=item *
-
-L<Bad symbol for scalar|perldiag/"Bad symbol for scalar"> is now documented.
-This error is not new, but was not previously documented here.
-
-=item *
-
-L<Missing right brace on \N{}|perldiag/"Missing right brace on \N{}"> is now
-documented. This error is not new, but was not previously documented here.
-
-=back
-
-=head1 Testing
-
-=over 4
-
-=item *
-
-The test script F<re/rt122747.t> has been added to verify that
-L<perl #122747|https://rt.perl.org/Ticket/Display.html?id=122747> remains
-fixed.
-
-=back
-
-=head1 Platform Support
-
-=head2 Regained Platforms
-
-IRIX and Tru64 platforms are working again. (Some C<make test> failures
-remain.)
-
-=head1 Selected Bug Fixes
-
-=over 4
-
-=item *
-
-AIX now sets the length in C<< getsockopt >> correctly.
-L<[perl #120835]|https://rt.perl.org/Ticket/Display.html?id=120835>,
-L<[cpan #91183]|https://rt.cpan.org/Ticket/Display.html?id=91183>,
-L<[cpan #85570]|https://rt.cpan.org/Ticket/Display.html?id=85570>
-
-=item *
-
-In Perl 5.20.0, C<$^N> accidentally had the internal UTF8 flag turned off if
-accessed from a code block within a regular expression, effectively
-UTF8-encoding the value. This has been fixed.
-L<[perl #123135]|https://rt.perl.org/Ticket/Display.html?id=123135>
-
-=item *
-
-Various cases where the name of a sub is used (autoload, overloading, error
-messages) used to crash for lexical subs, but have been fixed.
-
-=item *
-
-An assertion failure when parsing C<sort> with debugging enabled has been
-fixed.
-L<[perl #122771]|https://rt.perl.org/Ticket/Display.html?id=122771>
-
-=item *
-
-Loading UTF8 tables during a regular expression match could cause assertion
-failures under debugging builds if the previous match used the very same
-regular expression.
-L<[perl #122747]|https://rt.perl.org/Ticket/Display.html?id=122747>
-
-=item *
-
-Due to a mistake in the string-copying logic, copying the value of a state
-variable could instead steal the value and undefine the variable. This bug,
-introduced in Perl 5.20, would happen mostly for long strings (1250 chars or
-more), but could happen for any strings under builds with copy-on-write
-disabled.
-L<[perl #123029]|https://rt.perl.org/Ticket/Display.html?id=123029>
-
-=item *
-
-Fixed a bug that could cause perl to execute an infinite loop during
-compilation.
-L<[perl #122995]|https://rt.perl.org/Ticket/Display.html?id=122995>
-
-=item *
-
-On Win32, restoring in a child pseudo-process a variable that was C<local()>ed
-in a parent pseudo-process before the C<fork> happened caused memory corruption
-and a crash in the child pseudo-process (and therefore OS process).
-L<[perl #40565]|https://rt.perl.org/Ticket/Display.html?id=40565>
-
-=item *
-
-Tainted constants evaluated at compile time no longer cause unrelated
-statements to become tainted.
-L<[perl #122669]|https://rt.perl.org/Ticket/Display.html?id=122669>
-
-=item *
-
-Calling C<write> on a format with a C<^**> field could produce a panic in
-sv_chop() if there were insufficient arguments or if the variable used to fill
-the field was empty.
-L<[perl #123245]|https://rt.perl.org/Ticket/Display.html?id=123245>
-
-=item *
-
-In Perl 5.20.0, C<sort CORE::fake> where 'fake' is anything other than a
-keyword started chopping of the last 6 characters and treating the result as a
-sort sub name. The previous behaviour of treating "CORE::fake" as a sort sub
-name has been restored.
-L<[perl #123410]|https://rt.perl.org/Ticket/Display.html?id=123410>
-
-=item *
-
-A bug in regular expression patterns that could lead to segfaults and other
-crashes has been fixed. This occurred only in patterns compiled with C<"/i">,
-while taking into account the current POSIX locale (this usually means they
-have to be compiled within the scope of C<S<"use locale">>), and there must be
-a string of at least 128 consecutive bytes to match.
-L<[perl #123539]|https://rt.perl.org/Ticket/Display.html?id=123539>
-
-=item *
-
-C<qr/@array(?{block})/> no longer dies with "Bizarre copy of ARRAY".
-L<[perl #123344]|https://rt.perl.org/Ticket/Display.html?id=123344>
-
-=item *
-
-C<gmtime> no longer crashes with not-a-number values.
-L<[perl #123495]|https://rt.perl.org/Ticket/Display.html?id=123495>
-
-=item *
-
-Certain syntax errors in substitutions, such as C<< s/${<>{})// >>, would
-crash, and had done so since Perl 5.10. (In some cases the crash did not start
-happening until Perl 5.16.) The crash has, of course, been fixed.
-L<[perl #123542]|https://rt.perl.org/Ticket/Display.html?id=123542>
-
-=item *
-
-A memory leak in some regular expressions, introduced in Perl 5.20.1, has been
-fixed.
-L<[perl #123198]|https://rt.perl.org/Ticket/Display.html?id=123198>
-
-=item *
-
-C<< formline("@...", "a"); >> would crash. The C<FF_CHECKNL> case in
-pp_formline() didn't set the pointer used to mark the chop position, which led
-to the C<FF_MORE> case crashing with a segmentation fault. This has been
-fixed.
-L<[perl #123538]|https://rt.perl.org/Ticket/Display.html?id=123538>
-L<[perl #123622]|https://rt.perl.org/Ticket/Display.html?id=123622>
-
-=item *
-
-A possible buffer overrun and crash when parsing a literal pattern during
-regular expression compilation has been fixed.
-L<[perl #123604]|https://rt.perl.org/Ticket/Display.html?id=123604>
-
-=back
-
-=head1 Known Problems
-
-=over 4
-
-=item *
-
-It is a known bug that lexical subroutines cannot be used as the C<SUBNAME>
-argument to C<sort>. This will be fixed in a future version of Perl.
-
-=back
-
-=head1 Errata From Previous Releases
-
-=over 4
-
-=item *
-
-A regression has been fixed that was introduced in Perl 5.20.0 (fixed in Perl
-5.20.1 as well as here) in which a UTF-8 encoded regular expression pattern
-that contains a single ASCII lowercase letter does not match its uppercase
-counterpart.
-L<[perl #122655]|https://rt.perl.org/Ticket/Display.html?id=122655>
-
-=back
-
-=head1 Acknowledgements
-
-Perl 5.20.2 represents approximately 5 months of development since Perl 5.20.1
-and contains approximately 6,300 lines of changes across 170 files from 34
-authors.
-
-Excluding auto-generated files, documentation and release tools, there were
-approximately 1,900 lines of changes to 80 .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.20.2:
-
-Aaron Crane, Abigail, Andreas Voegele, Andy Dougherty, Anthony Heading,
-Aristotle Pagaltzis, Chris 'BinGOs' Williams, Craig A. Berry, Daniel Dragan,
-Doug Bell, Ed J, Father Chrysostomos, Glenn D. Golden, H.Merijn Brand, Hugo van
-der Sanden, James E Keenan, Jarkko Hietaniemi, Jim Cromie, Karen Etheridge,
-Karl Williamson, kmx, Matthew Horsfall, Max Maischein, Peter Martini, Rafael
-Garcia-Suarez, Ricardo Signes, Shlomi Fish, Slaven Rezic, Steffen Müller,
-Steve Hay, Tadeusz Sośnierz, Tony Cook, Yves Orton, Ævar Arnfjörð
-Bjarmason.
-
-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
-https://rt.perl.org/ . There may also be information at 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 please send it
-to perl5-security-report@perl.org. This points to a closed subscription
-unarchived mailing list, which includes all the core committers, who will be
-able to help assess the impact of issues, figure out a resolution, and help
-co-ordinate the release of patches to mitigate or fix the problem across all
-platforms on which Perl is supported. Please only use this address for
-security issues in the Perl core, not for modules independently distributed on
-CPAN.
-
-=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
system(s) Don't. Look at pp_system or use my_popen
getenv(s) PerlEnv_getenv(s)
- setenv(s, val) my_setenv(s, val)
+ setenv(s, val) my_putenv(s, val)
=head2 Miscellaneous functions
=head1 NAME
-perldelta - what is new for perl v5.20.3
+perldelta - what is new for perl v5.21.0
=head1 DESCRIPTION
-This document describes differences between the 5.20.2 release and the 5.20.3
+This document describes differences between the 5.21.0 release and the 5.20.0
release.
-If you are upgrading from an earlier release such as 5.20.1, first read
-L<perl5202delta>, which describes differences between 5.20.1 and 5.20.2.
-
-=head1 Incompatible Changes
-
-There are no changes intentionally incompatible with 5.20.2. If any exist,
-they are bugs, and we request that you submit a report. See L</Reporting Bugs>
-below.
-
=head1 Modules and Pragmata
=head2 Updated Modules and Pragmata
=item *
-L<Errno> has been upgraded from version 1.20_05 to 1.20_06.
-
-Add B<-P> to the pre-processor command-line on GCC 5. GCC added extra line
-directives, breaking parsing of error code definitions.
-L<[perl #123784]|https://rt.perl.org/Ticket/Display.html?id=123784>
-
-=item *
-
-L<Module::CoreList> has been upgraded from version 5.20150214 to 5.20150822.
-
-Updated to cover the latest releases of Perl.
-
-=item *
-
-L<perl5db.pl> has been upgraded from 1.44 to 1.44_01.
-
-The debugger would cause an assertion failure.
-L<[perl #124127]|https://rt.perl.org/Ticket/Display.html?id=124127>
-
-=back
-
-=head1 Documentation
-
-=head2 Changes to Existing Documentation
-
-=head3 L<perlfunc>
-
-=over 4
-
-=item *
-
-Mention that L<C<study()>|perlfunc/study> is currently a no-op.
-
-=back
-
-=head3 L<perlguts>
-
-=over 4
-
-=item *
-
-The OOK example has been updated to account for COW changes and a change in the
-storage of the offset.
-
-=back
-
-=head3 L<perlhacktips>
-
-=over 4
-
-=item *
-
-Documentation has been added illustrating the perils of assuming the contents
-of static memory pointed to by the return values of Perl wrappers for C library
-functions doesn't change.
-
-=back
-
-=head3 L<perlpodspec>
-
-=over 4
-
-=item *
-
-The specification of the POD language is changing so that the default encoding
-of PODs that aren't in UTF-8 (unless otherwise indicated) is CP1252 instead of
-ISO-8859-1 (Latin1).
-
-=back
-
-=head1 Utility Changes
-
-=head2 L<h2ph>
-
-=over 4
-
-=item *
-
-B<h2ph> now handles hexadecimal constants in the compiler's predefined macro
-definitions, as visible in C<$Config{cppsymbols}>.
-L<[perl #123784]|https://rt.perl.org/Ticket/Display.html?id=123784>
-
-=back
-
-=head1 Testing
-
-=over 4
-
-=item *
-
-F<t/perf/taint.t> has been added to see if optimisations with taint issues are
-keeping things fast.
-
-=item *
-
-F<t/porting/re_context.t> has been added to test that L<utf8> and its
-dependencies only use the subset of the C<$1..$n> capture vars that
-Perl_save_re_context() is hard-coded to localize, because that function has no
-efficient way of determining at runtime what vars to localize.
-
-=back
-
-=head1 Platform Support
-
-=head2 Platform-Specific Notes
-
-=over 4
-
-=item Win32
-
-=over 4
-
-=item *
-
-Previously, when compiling with a 64-bit Visual C++, every Perl XS module
-(including CPAN ones) and Perl aware C file would unconditionally have around a
-dozen warnings from F<hv_func.h>. These warnings have been silenced. GCC (all
-bitness) and 32-bit Visual C++ were not affected.
+L<feature> has been upgraded from version 1.36 to 1.37.
=item *
-B<miniperl.exe> is now built with B<-fno-strict-aliasing>, allowing 64-bit
-builds to complete with GCC 4.8.
-L<[perl #123976]|https://rt.perl.org/Ticket/Display.html?id=123976>
-
-=back
+L<Module::CoreList> has been upgraded from version 3.10 to 5.021001.
=back
-=head1 Selected Bug Fixes
+=head2 Removed Modules and Pragmata
=over 4
=item *
-Repeated global pattern matches in scalar context on large tainted strings were
-exponentially slow depending on the current match position in the string.
-L<[perl #123202]|https://rt.perl.org/Ticket/Display.html?id=123202>
-
-=item *
-
-The original visible value of L<C<$E<sol>>|perlvar/$E<sol>> is now preserved
-when it is set to an invalid value. Previously if you set C<$/> to a reference
-to an array, for example, perl would produce a runtime error and not set PL_rs,
-but Perl code that checked C<$/> would see the array reference.
-L<[perl #123218]|https://rt.perl.org/Ticket/Display.html?id=123218>
-
-=item *
-
-Perl 5.14.0 introduced a bug whereby C<eval { LABEL: }> would crash. This has
-been fixed.
-L<[perl #123652]|https://rt.perl.org/Ticket/Display.html?id=123652>
-
-=item *
-
-Extending an array cloned from a parent thread could result in "Modification of
-a read-only value attempted" errors when attempting to modify the new elements.
-L<[perl #124127]|https://rt.perl.org/Ticket/Display.html?id=124127>
-
-=item *
-
-Several cases of data used to store environment variable contents in core C
-code being potentially overwritten before being used have been fixed.
-L<[perl #123748]|https://rt.perl.org/Ticket/Display.html?id=123748>
-
-=item *
-
-UTF-8 variable names used in array indexes, unquoted UTF-8 HERE-document
-terminators and UTF-8 function names all now work correctly.
-L<[perl #124113]|https://rt.perl.org/Ticket/Display.html?id=124113>
-
-=item *
-
-A subtle bug introduced in Perl 5.20.2 involving UTF-8 in regular expressions
-and sometimes causing a crash has been fixed. A new test script has been added
-to test this fix; see under L</Testing>.
-L<[perl #124109]|https://rt.perl.org/Ticket/Display.html?id=124109>
+L<CGI> has been removed from the core. It is still available on the CPAN.
=item *
-Some patterns starting with C</.*..../> matched against long strings have been
-slow since Perl 5.8, and some of the form C</.*..../i> have been slow since
-Perl 5.18. They are now all fast again.
-L<[perl #123743]|https://rt.perl.org/Ticket/Display.html?id=123743>
-
-=item *
-
-Warning fatality is now ignored when rewinding the stack. This prevents
-infinite recursion when the now fatal error also causes rewinding of the stack.
-L<[perl #123398]|https://rt.perl.org/Ticket/Display.html?id=123398>
-
-=item *
-
-C<setpgrp($nonzero)> (with one argument) was accidentally changed in Perl 5.16
-to mean C<setpgrp(0)>. This has been fixed.
-
-=item *
-
-A crash with C<< %::=(); J->${\"::"} >> has been fixed.
-L<[perl #125541]|https://rt.perl.org/Ticket/Display.html?id=125541>
-
-=item *
-
-Regular expression possessive quantifier Perl 5.20 regression now fixed.
-C<qr/>I<PAT>C<{>I<min>,I<max>C<}+>C</> is supposed to behave identically to
-C<qr/(?E<gt>>I<PAT>C<{>I<min>,I<max>C<})/>. Since Perl 5.20, this didn't work
-if I<min> and I<max> were equal.
-L<[perl #125825]|https://rt.perl.org/Ticket/Display.html?id=125825>
+L<Module::Build> has been removed from the core. It is still available on the
+CPAN.
=item *
-Code like C</$a[/> used to read the next line of input and treat it as though
-it came immediately after the opening bracket. Some invalid code consequently
-would parse and run, but some code caused crashes, so this is now disallowed.
-L<[perl #123712]|https://rt.perl.org/Ticket/Display.html?id=123712>
+L<Package::Constants> has been removed from the core. It is still available on
+the CPAN.
=back
=head1 Acknowledgements
-Perl 5.20.3 represents approximately 7 months of development since Perl 5.20.2
-and contains approximately 3,200 lines of changes across 99 files from 26
-authors.
+Perl 5.21.0 represents approximately 12 hours of development since Perl 5.20.0
+and contains approximately 44,000 lines of changes across 190 files from 1
+author.
Excluding auto-generated files, documentation and release tools, there were
-approximately 1,500 lines of changes to 43 .pm, .t, .c and .h files.
+approximately 33,000 lines of changes to 140 .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.20.3:
-
-Alex Vandiver, Andy Dougherty, Aristotle Pagaltzis, Chris 'BinGOs' Williams,
-Craig A. Berry, Dagfinn Ilmari Mannsåker, Daniel Dragan, David Mitchell,
-Father Chrysostomos, H.Merijn Brand, James E Keenan, James McCoy, Jarkko
-Hietaniemi, Karen Etheridge, Karl Williamson, kmx, Lajos Veres, Lukas Mai,
-Matthew Horsfall, Petr Písař, Randy Stauner, Ricardo Signes, Sawyer X, Steve
-Hay, 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.
+of users and developers. The following people are known to have contributed the
+improvements that became Perl 5.21.0:
+
+Nicholas Clark, Ricardo Signes.
For a more complete list of all of Perl's historical contributors, please see
the F<AUTHORS> file in the Perl source distribution.
(P) An internal request asked to add a hash entry to something that
wasn't a symbol table entry.
-=item Bad symbol for scalar
-
-(P) An internal request asked to add a scalar entry to something that
-wasn't a symbol table entry.
-
=item Bareword found in conditional
(W bareword) The compiler found a bareword where it expected a
functioning as a class, but that package doesn't define that particular
method, nor does any of its base classes. See L<perlobj>.
-=item Can't locate object method "%s" via package "%s" (perhaps you forgot
-to load "%s"?)
-
-(F) You called a method on a class that did not exist, and the method
-could not be found in UNIVERSAL. This often means that a method
-requires a package that has not been loaded.
-
=item Can't locate package %s for @%s::ISA
(W syntax) The @ISA array contained the name of another package that
=item "\c%c" is more clearly written simply as "%s"
(W syntax) The C<\cI<X>> construct is intended to be a way to specify
-non-printable characters. You used it for a printable one, which
-is better written as simply itself, perhaps preceded by a backslash
-for non-word characters. Doing it the way you did is not portable
-between ASCII and EBCDIC platforms.
+non-printable characters. You used it for a printable one, which is better
+written as simply itself, perhaps preceded by a backslash for non-word
+characters.
=item Cloning substitution context is unimplemented
not finding it. Chances are you left some needed parentheses out
earlier in the line, and you really meant a "less than".
-=item gmtime(%f) failed
-
-(W overflow) You called C<gmtime> with a number that it could not handle:
-too large, too small, or NaN. The returned value is C<undef>.
-
=item gmtime(%f) too large
(W overflow) You called C<gmtime> with a number that was larger than
=item Ignoring zero length \N{} in character class in regex; marked by
S<<-- HERE> in m/%s/
-(W regexp) Named Unicode character escapes (C<\N{...}>) may return a
+(W regexp) Named Unicode character escapes C<(\N{...})> may return a
zero-length sequence. When such an escape is used in a character class
its behaviour is not well defined. Check that the correct escape has
been used, and the correct charname handler is in scope.
=item Invalid negative number (%s) in chr
(W utf8) You passed a negative number to C<chr>. Negative numbers are
-not valid character numbers, so it returns the Unicode replacement
+not valid characters numbers, so it return the Unicode replacement
character (U+FFFD).
=item invalid option -D%c, use -D'' to see choices
form of C<open> does not support pipes, such as C<open($pipe, '|-', @args)>.
Use the two-argument C<open($pipe, '|prog arg1 arg2...')> form instead.
-=item localtime(%f) failed
-
-(W overflow) You called C<localtime> with a number that it could not handle:
-too large, too small, or NaN. The returned value is C<undef>.
-
=item localtime(%f) too large
(W overflow) You called C<localtime> with a number that was larger
(F) Missing right brace in C<\x{...}>, C<\p{...}>, C<\P{...}>, or C<\N{...}>.
-=item Missing right brace on \N{}
-
=item Missing right brace on \N{} or unescaped left brace after \N
(F) C<\N> has two meanings.
=item \N{} in character class restricted to one character in regex; marked
by S<<-- HERE> in m/%s/
-(F) Named Unicode character escapes (C<\N{...}>) may return a
+(F) Named Unicode character escapes C<(\N{...})> may return a
multi-character sequence. Such an escape may not be used in
a character class, because character classes always match one
character of input. Check that the correct escape has been used,
command-line switch. (This output goes to STDOUT unless you've
redirected it with select().)
+=item (perhaps you forgot to load "%s"?)
+
+(F) This is an educated guess made in conjunction with the message
+"Can't locate object method \"%s\" via package \"%s\"". It often means
+that a method requires a package that has not been loaded.
+
=item Perl folding rules are not up-to-date for 0x%X; please use the perlbug
utility to report; in regex; marked by S<<-- HERE> in m/%s/
=item Variable length lookbehind not implemented in regex m/%s/
(F) Lookbehind is allowed only for subexpressions whose length is fixed and
-known at compile time. For positive lookbehind, you can use the C<\K>
-regex construct as a way to get the equivalent functionality. See
-L<perlre/(?<=pattern) \K>.
-
-There are non-obvious Unicode rules under C</i> that can match variably,
-but which you might not think could. For example, the substring C<"ss">
-can match the single character LATIN SMALL LETTER SHARP S. There are
-other sequences of ASCII characters that can match single ligature
-characters, such as LATIN SMALL LIGATURE FFI matching C<qr/ffi/i>.
-Starting in Perl v5.16, if you only care about ASCII matches, adding the
-C</aa> modifier to the regex will exclude all these non-obvious matches,
-thus getting rid of this message. You can also say C<S<use re qw(/aa)>>
-to apply C</aa> to all regular expressions compiled within its scope.
-See L<re>.
+known at compile time. See L<perlre>.
=item "%s" variable %s masks earlier declaration in same %s
=item Zero length \N{} in regex; marked by S<<-- HERE> in m/%s/
-(F) Named Unicode character escapes (C<\N{...}>) may return a zero-length
+(F) Named Unicode character escapes C<(\N{...})> may return a zero-length
sequence. Such an escape was used in an extended character class, i.e.
C<(?[...])>, which is not permitted. Check that the correct escape has
been used, and the correct charnames handler is in scope. The S<<-- HERE>
Introduced in Perl 5.18
-=item Subroutine signatures
-
-Introduced in Perl 5.20.0
-
-Using this feature triggers warnings in the category
-C<experimental::signatures>.
-
-The ticket for this feature is
-L<[perl #121481]|https://rt.perl.org/Ticket/Display.html?id=121481>.
-
=item Postfix dereference syntax
Introduced in Perl 5.20.0
=back
-=head1 SEE ALSO
-
-For a complete list of features check L<feature>.
-
=head1 AUTHORS
brian d foy C<< <brian.d.foy@gmail.com> >>
after their pseudo-children have exited.
Starting with Perl 5.14 a parent will not wait() automatically
-for any child that has been signalled with C<kill('TERM', ...)>
+for any child that has been signalled with C<sig('TERM', ...)>
to avoid a deadlock in case the child is blocking on I/O and
never receives the signal.
BEGIN block. For example, consider the following code:
BEGIN {
- fork and exit; # fork child and exit the parent
- print "inner\n";
+ fork and exit; # fork child and exit the parent
+ print "inner\n";
}
print "outer\n";
On some operating systems, notably Solaris and Unixware, calling C<exit()>
from a child process will flush and close open filehandles in the parent,
thereby corrupting the filehandles. On these systems, calling C<_exit()>
-is suggested instead. C<_exit()> is available in Perl through the
+is suggested instead. C<_exit()> is available in Perl through the
C<POSIX> module. Please consult your system's manpages for more information
on this.
# simulate open(FOO, "|-")
sub pipe_to_fork ($) {
- my $parent = shift;
- pipe my $child, $parent or die;
- my $pid = fork();
- die "fork() failed: $!" unless defined $pid;
- if ($pid) {
- close $child;
- }
- else {
- close $parent;
- open(STDIN, "<&=" . fileno($child)) or die;
- }
- $pid;
+ my $parent = shift;
+ pipe my $child, $parent or die;
+ my $pid = fork();
+ die "fork() failed: $!" unless defined $pid;
+ if ($pid) {
+ close $child;
+ }
+ else {
+ close $parent;
+ open(STDIN, "<&=" . fileno($child)) or die;
+ }
+ $pid;
}
if (pipe_to_fork('FOO')) {
- # parent
- print FOO "pipe_to_fork\n";
- close FOO;
+ # parent
+ print FOO "pipe_to_fork\n";
+ close FOO;
}
else {
- # child
- while (<STDIN>) { print; }
- exit(0);
+ # child
+ while (<STDIN>) { print; }
+ exit(0);
}
And this one reads from the child:
# simulate open(FOO, "-|")
sub pipe_from_fork ($) {
- my $parent = shift;
- pipe $parent, my $child or die;
- my $pid = fork();
- die "fork() failed: $!" unless defined $pid;
- if ($pid) {
- close $child;
- }
- else {
- close $parent;
- open(STDOUT, ">&=" . fileno($child)) or die;
- }
- $pid;
+ my $parent = shift;
+ pipe $parent, my $child or die;
+ my $pid = fork();
+ die "fork() failed: $!" unless defined $pid;
+ if ($pid) {
+ close $child;
+ }
+ else {
+ close $parent;
+ open(STDOUT, ">&=" . fileno($child)) or die;
+ }
+ $pid;
}
if (pipe_from_fork('BAR')) {
- # parent
- while (<BAR>) { print; }
- close BAR;
+ # parent
+ while (<BAR>) { print; }
+ close BAR;
}
else {
- # child
- print "pipe_from_fork\n";
- exit(0);
+ # child
+ print "pipe_from_fork\n";
+ exit(0);
}
Forking pipe open() constructs will be supported in future.
-=item Global state maintained by XSUBs
+=item Global state maintained by XSUBs
External subroutines (XSUBs) that maintain their own global state may
not work correctly. Such XSUBs will either need to maintain locks to
-f File is a plain file.
-d File is a directory.
- -l File is a symbolic link (false if symlinks aren't
- supported by the file system).
+ -l File is a symbolic link.
-p File is a named pipe (FIFO), or Filehandle is a pipe.
-S File is a socket.
-b File is a block special file.
-g File has setgid bit set.
-k File has sticky bit set.
- -T File is an ASCII or UTF-8 text file (heuristic guess).
+ -T File is an ASCII text file (heuristic guess).
-B File is a "binary" file (opposite of -T).
-M Script start time minus file modification time, in days.
in effect. Read the documentation for the C<filetest> pragma for more
information.
-The C<-T> and C<-B> switches work as follows. The first block or so of
-the file is examined to see if it is valid UTF-8 that includes non-ASCII
-characters. If, so it's a C<-T> file. Otherwise, that same portion of
-the file is examined for odd characters such as strange control codes or
-characters with the high bit set. If more than a third of the
-characters are strange, it's a C<-B> file; otherwise it's a C<-T> file.
-Also, any file containing a zero byte in the examined portion is
-considered a binary file. (If executed within the scope of a L<S<use
-locale>|perllocale> which includes C<LC_CTYPE>, odd characters are
-anything that isn't a printable nor space in the current locale.) If
-C<-T> or C<-B> is used on a filehandle, the current IO buffer is
-examined
+The C<-T> and C<-B> switches work as follows. The first block or so of the
+file is examined for odd characters such as strange control codes or
+characters with the high bit set. If too many strange characters (>30%)
+are found, it's a C<-B> file; otherwise it's a C<-T> file. Also, any file
+containing a zero byte in the first block is considered a binary file. If C<-T>
+or C<-B> is used on a filehandle, the current IO buffer is examined
rather than the first block. Both C<-T> and C<-B> return true on an empty
file, or a file at EOF when testing a filehandle. Because you have to
read a file to do the C<-T> test, on most occasions you want to use a C<-f>
context, returns the caller's package name if there I<is> a caller (that is, if
we're in a subroutine or C<eval> or C<require>) and the undefined value
otherwise. caller never returns XS subs and they are skipped. The next pure
-perl sub will appear instead of the XS
-sub in caller's return values. In list
+perl sub will appear instead of the XS sub in caller's return values. In list
context, caller returns
# 0 1 2
= caller($i);
Here, $subroutine is the function that the caller called (rather than the
-function containing the caller). Note that $subroutine may be C<(eval)> if
+function containing the caller). Note that $subroutine may be C<(eval)> if
the frame is not a subroutine call, but an C<eval>. In such a case
additional elements $evaltext and
C<$is_require> are set: C<$is_require> is true if the frame is created by a
deleting array elements never changes indices of existing values; use shift()
or splice() for that. However, if any deleted elements fall at the end of an
array, the array's size shrinks to the position of the highest element that
-still tests true for exists(), or to 0 if none do. In other words, an
+still tests true for exists(), or to 0 if none do. In other words, an
array won't have trailing nonexistent elements after a delete.
-B<WARNING:> Calling C<delete> on array values is strongly discouraged. The
-notion of deleting or checking the existence of Perl array elements is not
-conceptually coherent, and can lead to surprising behavior.
+B<WARNING:> Calling delete on array values is deprecated and likely to
+be removed in a future version of Perl.
Deleting from C<%ENV> modifies the environment. Deleting from a hash tied to
a DBM file deletes the entry from the DBM file. Deleting from a C<tied> hash
delete $hash{$key}; # This is safe
}
-Tied hashes may have a different ordering behaviour to perl's hash
-implementation.
-
This prints out your environment like the printenv(1) program,
but in a different order:
If you don't really want to execute the first argument, but want to lie
to the program you are executing about its own name, you can specify
the program you actually want to run as an "indirect object" (without a
-comma) in front of the LIST, as in C<exec PROGRAM LIST>. (This always
-forces interpretation of the LIST as a multivalued list, even if there
-is only a single scalar in the list.) Example:
+comma) in front of the LIST. (This always forces interpretation of the
+LIST as a multivalued list, even if there is only a single scalar in
+the list.) Example:
$shell = '/bin/csh';
exec $shell '-sh'; # pretend it's a login shell
it tried to run a program named I<"echo surprise">, didn't find it, and set
C<$?> to a non-zero value indicating failure.
-On Windows, only the C<exec PROGRAM LIST> indirect object syntax will
-reliably avoid using the shell; C<exec LIST>, even with more than one
-element, will fall back to the shell if the first spawn fails.
-
Perl attempts to flush all files opened for output before the exec,
but this may not be supported on some platforms (see L<perlport>).
To be safe, you may need to set C<$|> ($AUTOFLUSH in English) or
print "True\n" if $hash{$key};
exists may also be called on array elements, but its behavior is much less
-obvious and is strongly tied to the use of L</delete> on arrays.
-
-B<WARNING:> Calling C<exists> on array values is strongly discouraged. The
-notion of deleting or checking the existence of Perl array elements is not
-conceptually coherent, and can lead to surprising behavior.
+obvious and is strongly tied to the use of L</delete> on arrays. B<Be aware>
+that calling exists on array values is deprecated and likely to be removed in
+a future version of Perl.
print "Exists\n" if exists $array[$index];
print "Defined\n" if defined $array[$index];
as each other. See L<perlsec/"Algorithmic Complexity Attacks"> for
details on why hash order is randomized. Aside from the guarantees
provided here the exact details of Perl's hash algorithm and the hash
-traversal order are subject to change in any release of Perl. Tied hashes
-may behave differently to Perl's hashes with respect to changes in order on
-insertion and deletion of items.
+traversal order are subject to change in any release of Perl.
As a side effect, calling keys() resets the internal iterator of the HASH or
ARRAY (see L</each>). In particular, calling keys() in void context resets
rules for the remaining code points (this last can only happen if
the UTF8 flag is also set). See L<perllocale>.
-Starting in v5.20, Perl uses full Unicode rules if the locale is
+Starting in v5.20, Perl wil use full Unicode rules if the locale is
UTF-8. Otherwise, there is a deficiency in this scheme, which is that
case changes that cross the 255/256
boundary are not well-defined. For example, the lower case of LATIN CAPITAL
doesn't it won't realize something is wrong until it gets to the C<}> and
encounters the missing (or unexpected) comma. The syntax error will be
reported close to the C<}>, but you'll need to change something near the C<{>
-such as using a unary C<+> or semicolon to give Perl some help:
+such as using a unary C<+> to give Perl some help:
%hash = map { "\L$_" => 1 } @array # perl guesses EXPR. wrong
%hash = map { +"\L$_" => 1 } @array # perl guesses BLOCK. right
- %hash = map {; "\L$_" => 1 } @array # this also works
- %hash = map { ("\L$_" => 1) } @array # as does this
- %hash = map { lc($_) => 1 } @array # and this.
+ %hash = map { ("\L$_" => 1) } @array # this also works
+ %hash = map { lc($_) => 1 } @array # as does this.
%hash = map +( lc($_) => 1 ), @array # this is EXPR and works!
%hash = map ( lc($_), 1 ), @array # evaluates to (1, @array)
=for Pod::Functions +5.6.0 declare and assign a package variable (lexical scoping)
-C<our> makes a lexical alias to a package (i.e. global) variable of the
-same name in the current package for use within the current lexical scope.
+C<our> makes a lexical alias to a package variable of the same name in the current
+package for use within the current lexical scope.
-C<our> has the same scoping rules as C<my> or C<state>, meaning that it is
-only valid within a lexical scope. Unlike C<my> and C<state>, which both
-declare new (lexical) variables, C<our> only creates an alias to an
-existing variable: a package variable of the same name.
+C<our> has the same scoping rules as C<my> or C<state>, but C<our> only
+declares an alias, whereas C<my> or C<state> both declare a variable name and
+allocate storage for that name within the current scope.
This means that when C<use strict 'vars'> is in effect, C<our> lets you use
a package variable without qualifying it with the package name, but only within
-the lexical scope of the C<our> declaration. This applies immediately--even
-within the same statement.
-
- package Foo;
- use strict;
-
- $Foo::foo = 23;
-
- {
- our $foo; # alias to $Foo::foo
- print $foo; # prints 23
- }
-
- print $Foo::foo; # prints 23
-
- print $foo; # ERROR: requires explicit package name
-
-This works even if the package variable has not been used before, as
-package variables spring into existence when first used.
-
- package Foo;
- use strict;
-
- our $foo = 23; # just like $Foo::foo = 23
-
- print $Foo::foo; # prints 23
-
-Because the variable becomes legal immediately under C<use strict 'vars'>, so
-long as there is no variable with that name is already in scope, you can then
-reference the package variable again even within the same statement.
-
- package Foo;
- use strict;
-
- my $foo = $foo; # error, undeclared $foo on right-hand side
- our $foo = $foo; # no errors
+the lexical scope of the C<our> declaration. In this way, C<our> differs from
+C<use vars>, which allows use of an unqualified name I<only> within the
+affected package, but across scopes.
If more than one variable is listed, the list must be placed
in parentheses.
+ our $foo;
our($bar, $baz);
An C<our> declaration declares an alias for a package variable that will be visible
our ( undef, $min, $hour ) = localtime;
-C<our> differs from C<use vars>, which allows use of an unqualified name
-I<only> within the affected package, but across scopes.
-
=item pack TEMPLATE,LIST
X<pack>
C<state> variables are enabled only when the C<use feature "state"> pragma
is in effect, unless the keyword is written as C<CORE::state>.
-See also L<feature>. Alternately, include a C<use v5.10> or later to the
-current scope.
+See also L<feature>.
=item study SCALAR
X<study>
=for Pod::Functions optimize input data for repeated searches
-May take extra time to study SCALAR (C<$_> if unspecified) in anticipation
-of doing many pattern matches on the string before it is next modified.
+Takes extra time to study SCALAR (C<$_> if unspecified) in anticipation of
+doing many pattern matches on the string before it is next modified.
This may or may not save time, depending on the nature and number of
patterns you are searching and the distribution of character
frequencies in the string to be searched; you probably want to compare
run times with and without it to see which is faster. Those loops
that scan for many short constant strings (including the constant
parts of more complex patterns) will benefit most.
-
-Note that since Perl version 5.16 this function has been a no-op, but
-this might change in a future release.
-
(The way C<study> works is this: a linked list of every
character in the string to be searched is made, so we know, for
example, where all the C<'k'> characters are. From each search string,
(this is C</bin/sh -c> on Unix platforms, but varies on other
platforms). If there are no shell metacharacters in the argument,
it is split into words and passed directly to C<execvp>, which is
-more efficient. On Windows, only the C<system PROGRAM LIST> syntax will
-reliably avoid using the shell; C<system LIST>, even with more than one
-element, will fall back to the shell if the first spawn fails.
+more efficient.
Perl will attempt to flush all files opened for
output before any operation that may do a fork, but this may not be
C<use>ing library modules that won't work with older versions of Perl.
(We try not to do this more than we have to.)
-C<use VERSION> also lexically enables all features available in the requested
+C<use VERSION> also enables all features available in the requested
version as defined by the C<feature> pragma, disabling any features
not in the requested version's feature bundle. See L<feature>.
Similarly, if the specified Perl version is greater than or equal to
5.12.0, strictures are enabled lexically as
with C<use strict>. Any explicit use of
C<use strict> or C<no strict> overrides C<use VERSION>, even if it comes
-before it. Later use of C<use VERSION>
-will override all behavior of a previous
-C<use VERSION>, possibly removing the C<strict> and C<feature> added by
-C<use VERSION>. C<use VERSION> does not
-load the F<feature.pm> or F<strict.pm>
-files.
+before it. In both cases, the F<feature.pm> and F<strict.pm> files are
+not actually loaded.
The C<BEGIN> forces the C<require> and C<import> to happen at compile time. The
C<require> makes sure the module is loaded into memory if it hasn't been
as each other. See L<perlsec/"Algorithmic Complexity Attacks"> for
details on why hash order is randomized. Aside from the guarantees
provided here the exact details of Perl's hash algorithm and the hash
-traversal order are subject to change in any release of Perl. Tied hashes
-may behave differently to Perl's hashes with respect to changes in order on
-insertion and deletion of items.
+traversal order are subject to change in any release of Perl.
As a side effect, calling values() resets the HASH or ARRAY's internal
iterator, see L</each>. (In particular, calling values() in void context
Note that a return value of C<-1> could mean that child processes are
being automatically reaped, as described in L<perlipc>.
-If you use C<wait> in your handler for $SIG{CHLD}, it may accidentally wait
-
for the child created by qx() or system(). See L<perlipc> for details.
+If you use wait in your handler for $SIG{CHLD} it may accidentally for the
+child created by qx() or system(). See L<perlipc> for details.
Portability issues: L<perlport/wait>.
=item else
+=item elseif
+
=item elsif
=item for
These flow-control keywords are documented in L<perlsyn/"Compound Statements">.
-=item elseif
-
-The "else if" keyword is spelled C<elsif> in Perl. There's no C<elif>
-or C<else if> either. It does parse C<elseif>, but only to warn you
-about not using it.
-
-See the documentation for flow-control keywords in L<perlsyn/"Compound
-Statements">.
-
=back
=over
Now you should create a patch file for all your local changes:
- % git format-patch -M blead..
+ % git format-patch -M origin..
0001-Rename-Leon-Brocard-to-Orange-Brocard.patch
Or for a lot of changes, e.g. from a topic branch:
- % git format-patch --stdout -M blead.. > topic-branch-changes.patch
+ % git format-patch --stdout -M origin.. > topic-branch-changes.patch
You should now send an email to
L<perlbug@perl.org|mailto:perlbug@perl.org> with a description of your
L<perl5-porters@perl.org|mailto:perl5-porters@perl.org> directly if the
patch is not ready to be applied, but intended for discussion.
-Please do not use git-send-email(1) to send your patch. See L<Sending
-patch emails|/Sending patch emails> for more information.
+See the next section for how to configure and use git to send these
+emails for you.
If you want to delete your temporary branch, you may do so with:
After you've generated your patch you should sent it
to perlbug@perl.org (as discussed L<in the previous
-section|/"Patch workflow">) with a normal mail client as an
+section|/"Patch workflow"> with a normal mail client as an
attachment, along with a description of the patch.
You B<must not> use git-send-email(1) to send patches generated with
to an array of UVs. But,
using it for non-strings requires care, as the underlying assumption of
much of the internals is that PVs are just for strings. Often, for
-example, a trailing C<NUL> is tacked on automatically. The non-string use
+example, a trailing NUL is tacked on automatically. The non-string use
is documented only in this paragraph.)
The seven routines are:
In the unlikely case of a SV requiring more complex initialization, you
can create an empty SV with newSV(len). If C<len> is 0 an empty SV of
type NULL is returned, else an SV of type PV is returned with len + 1 (for
-the C<NUL>) bytes of storage allocated, accessible via SvPVX. In both cases
+the NUL) bytes of storage allocated, accessible via SvPVX. In both cases
the SV has the undef value.
SV *sv = newSV(0); /* no storage allocated */
allow Perl to calculate the length by using C<sv_setpv> or by specifying
0 as the second argument to C<newSVpv>. Be warned, though, that Perl will
determine the string's length by using C<strlen>, which depends on the
-string terminating with a C<NUL> character, and not otherwise containing
+string terminating with a NUL character, and not otherwise containing
NULs.
The arguments of C<sv_setpvf> are processed like C<sprintf>, and the
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.
-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
+All SVs that contain strings should be terminated with a NUL character.
+If it is not NUL-terminated there is a risk of
core dumps and corruptions from code which passes the string to C
-functions or system calls which expect a C<NUL>-terminated string.
-Perl's own functions typically add a trailing C<NUL> for this reason.
+functions or system calls which expect a NUL-terminated string.
+Perl's own functions typically add a trailing NUL for this reason.
Nevertheless, you should be very careful when you pass a string stored
in an SV to a C function or system call.
used in this case. But that can be quite inefficient because C<PL_na> must
be accessed in thread-local storage in threaded Perl. In any case, remember
that Perl allows arbitrary strings of data that may both contain NULs and
-might not be terminated by a C<NUL>.
+might not be terminated by a NUL.
Also remember that C doesn't allow you to safely say C<foo(SvPV(s, len),
len);>. It might work with your
which will determine if more memory needs to be allocated. If so, it will
call the function C<sv_grow>. Note that C<SvGROW> can only increase, not
decrease, the allocated memory of an SV and that it does not automatically
-add space for the trailing C<NUL> byte (perl's own string functions typically do
+add space for the trailing NUL byte (perl's own string functions typically do
C<SvGROW(sv, len + 1)>).
-If you want to write to an existing SV's buffer and set its value to a
-string, use SvPV_force() or one of its variants to force the SV to be
-a PV. This will remove any of various types of non-stringness from
-the SV while preserving the content of the SV in the PV. This can be
-used, for example, to append data from an API function to a buffer
-without extra copying:
-
- (void)SvPVbyte_force(sv, len);
- s = SvGROW(sv, len + needlen + 1);
- /* something that modifies up to needlen bytes at s+len, but
- modifies newlen bytes
- eg. newlen = read(fd, s + len, needlen);
- ignoring errors for these examples
- */
- s[len + newlen] = '\0';
- SvCUR_set(sv, len + newlen);
- SvUTF8_off(sv);
- SvSETMAGIC(sv);
-
-If you already have the data in memory or if you want to keep your
-code simple, you can use one of the sv_cat*() variants, such as
-sv_catpvn(). If you want to insert anywhere in the string you can use
-sv_insert() or sv_insert_flags().
-
-If you don't need the existing content of the SV, you can avoid some
-copying with:
-
- sv_setpvn(sv, "", 0);
- s = SvGROW(sv, needlen + 1);
- /* something that modifies up to needlen bytes at s, but modifies
- newlen bytes
- eg. newlen = read(fd, s. needlen);
- */
- s[newlen] = '\0';
- SvCUR_set(sv, newlen);
- SvPOK_only(sv); /* also clears SVf_UTF8 */
- SvSETMAGIC(sv);
-
-Again, if you already have the data in memory or want to avoid the
-complexity of the above, you can use sv_setpvn().
-
-If you have a buffer allocated with Newx() and want to set that as the
-SV's value, you can use sv_usepvn_flags(). That has some requirements
-if you want to avoid perl re-allocating the buffer to fit the trailing
-NUL:
-
- Newx(buf, somesize+1, char);
- /* ... fill in buf ... */
- buf[somesize] = '\0';
- sv_usepvn_flags(sv, buf, somesize, SV_SMAGIC | SV_HAS_TRAILING_NUL);
- /* buf now belongs to perl, don't release it */
-
If you have an SV and want to know what kind of data Perl thinks is stored
in it, you can use the following macros to check the type of SV you have.
at C<SvPVX(sv) - SvIV(sv)> in memory and the PV pointer is pointing
into the middle of this allocated storage.
-This is best demonstrated by example. Normally copy-on-write will prevent
-the substitution from operator from using this hack, but if you can craft a
-string for which copy-on-write is not possible, you can see it in play. In
-the current implementation, the final byte of a string buffer is used as a
-copy-on-write reference count. If the buffer is not big enough, then
-copy-on-write is skipped. First have a look at an empty string:
-
- % ./perl -Ilib -MDevel::Peek -le '$a=""; $a .= ""; Dump $a'
- SV = PV(0x7ffb7c008a70) at 0x7ffb7c030390
- REFCNT = 1
- FLAGS = (POK,pPOK)
- PV = 0x7ffb7bc05b50 ""\0
- CUR = 0
- LEN = 10
-
-Notice here the LEN is 10. (It may differ on your platform.) Extend the
-length of the string to one less than 10, and do a substitution:
+This is best demonstrated by example:
- % ./perl -Ilib -MDevel::Peek -le '$a=""; $a.="123456789"; $a=~s/.//; Dump($a)'
- SV = PV(0x7ffa04008a70) at 0x7ffa04030390
+ % ./perl -Ilib -MDevel::Peek -le '$a="12345"; $a=~s/.//; Dump($a)'
+ SV = PVIV(0x8128450) at 0x81340f0
REFCNT = 1
FLAGS = (POK,OOK,pPOK)
- OFFSET = 1
- PV = 0x7ffa03c05b61 ( "\1" . ) "23456789"\0
- CUR = 8
- LEN = 9
+ IV = 1 (OFFSET)
+ PV = 0x8135781 ( "1" . ) "2345"\0
+ CUR = 4
+ LEN = 5
-Here the number of bytes chopped off (1) is shown next as the OFFSET. The
+Here the number of bytes chopped off (1) is put into IV, and
+C<Devel::Peek::Dump> helpfully reminds us that this is an offset. The
portion of the string between the "real" and the "fake" beginnings is
shown in parentheses, and the values of C<SvCUR> and C<SvLEN> reflect
-the fake beginning, not the real one. (The first character of the string
-buffer happens to have changed to "\1" here, not "1", because the current
-implementation stores the offset count in the string buffer. This is
-subject to change.)
+the fake beginning, not the real one.
Something similar to the offset hack is performed on AVs to enable
efficient shifting and splicing off the beginning of the array; while
targets for opcodes. A previous version of this document
stated that one can deduce that an SV lives on a scratchpad
by looking on its flags: lexicals have C<SVs_PADMY> set, and
-I<target>s have C<SVs_PADTMP> set. But this has never been fully true.
+I<target>s have C<SVs_PADTMP> set. But this have never been fully true.
C<SVs_PADMY> could be set on a variable that no longer resides in any pad.
While I<target>s do have C<SVs_PADTMP> set, it can also be set on variables
that have never resided in a pad, but nonetheless act like I<target>s.
"porters".
A searchable archive of the list is available at
-L<http://markmail.org/search/?q=perl5-porters>. There is also an archive at
+L<http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/>. There is
+also another archive at
L<http://archive.develooper.com/perl5-porters@perl.org/>.
=head2 perl-changes mailing list
But in any case, try to keep the features and operating systems
separate.
-=item *
-
-Assuming the contents of static memory pointed to by the return values
-of Perl wrappers for C library functions doesn't change. Many C library
-functions return pointers to static storage that can be overwritten by
-subsequent calls to the same or related functions. Perl has
-light-weight wrappers for some of these functions, and which don't make
-copies of the static memory. A good example is the interface to the
-environment variables that are in effect for the program. Perl has
-C<PerlEnv_getenv> to get values from the environment. But the return is
-a pointer to static memory in the C library. If you are using the value
-to immediately test for something, that's fine, but if you save the
-value and expect it to be unchanged by later processing, you would be
-wrong, but perhaps you wouldn't know it because different C library
-implementations behave differently, and the one on the platform you're
-testing on might work for your situation. But on some platforms, a
-subsequent call to C<PerlEnv_getenv> or related function WILL overwrite
-the memory that your first call points to. This has led to some
-hard-to-debug problems. Do a L<perlapi/savepv> to make a copy, thus
-avoiding these problems. You will have to free the copy when you're
-done to avoid memory leaks. If you don't have control over when it gets
-freed, you'll need to make the copy in a mortal scalar, like so:
-
- if ((s = PerlEnv_getenv("foo") == NULL) {
- ... /* handle NULL case */
- }
- else {
- s = SvPVX(sv_2mortal(newSVpv(s, 0)));
- }
-
-The above example works only if C<"s"> is C<NUL>-terminated; otherwise
-you have to pass its length to C<newSVpv>.
-
=back
=head2 Problematic System Interfaces
=head2 Security problems
Last but not least, here are various tips for safer coding.
-See also L<perlclib> for libc/stdio replacements one should use.
=over 4
=item *
-Do not use tmpfile()
-
-Use mkstemp() instead.
-
-=item *
-
Do not use strcpy() or strcat() or strncpy() or strncat()
Use my_strlcpy() and my_strlcat() instead: they either use the native
Matt S Trout, David Golden, Florian Ragwitz, Tatsuhiko Miyagawa,
Chris C<BinGOs> Williams, Zefram, Ævar Arnfjörð Bjarmason, Stevan
Little, Dave Rolsky, Max Maischein, Abigail, Jesse Luehrs, Tony Cook,
-Dominic Hargreaves, Aaron Crane, Aristotle Pagaltzis, Matthew Horsfall,
-Peter Martini, and Sawyer X.
+Dominic Hargreaves, Aaron Crane and Aristotle Pagaltzis.
=head2 PUMPKIN?
Ricardo 5.18.1-RC3 2013-Aug-08
Ricardo 5.18.1 2013-Aug-12
Ricardo 5.18.2 2014-Jan-06
- Ricardo 5.18.3-RC1 2014-Sep-17
- Ricardo 5.18.3-RC2 2014-Sep-27
- Ricardo 5.18.3 2014-Oct-01
- Ricardo 5.18.4 2014-Oct-01
Ricardo 5.19.0 2013-May-20 The 5.19 development track
David G 5.19.1 2013-Jun-21
Ricardo 5.20.0-RC1 2014-May-16 The 5.20 maintenance track
Ricardo 5.20.0 2014-May-27
- Steve 5.20.1-RC1 2014-Aug-25
- Steve 5.20.1-RC2 2014-Sep-07
- Steve 5.20.1 2014-Sep-14
- Steve 5.20.2-RC1 2015-Jan-31
- Steve 5.20.2 2015-Feb-14
- Steve 5.20.3-RC1 2015-Aug-22
- Steve 5.20.3-RC2 2015-Aug-29
- Steve 5.20.3 2015-Sep-12
-
- Ricardo 5.21.0 2014-May-27 The 5.21 development track
- Matthew H 5.21.1 2014-Jun-20
- Abigail 5.21.2 2014-Jul-20
- Peter 5.21.3 2014-Aug-20
- Steve 5.21.4 2014-Sep-20
- Abigail 5.21.5 2014-Oct-20
- BinGOs 5.21.6 2014-Nov-20
- Max M 5.21.7 2014-Dec-20
- Matthew H 5.21.8 2015-Jan-20
- Sawyer X 5.21.9 2015-Feb-20
- Steve 5.21.10 2015-Mar-20
- Steve 5.21.11 2015-Apr-20
-
- Ricardo 5.22.0-RC1 2015-May-19 The 5.22 maintenance track
- Ricardo 5.22.0-RC2 2015-May-21
- Ricardo 5.22.0 2015-Jun-01
-
- Ricardo 5.23.0 2015-Jun-20 The 5.23 development track
- Matthew 5.23.1 2015-Jul-20
- Matthew 5.23.2 2015-Aug-20
=head2 SELECTED RELEASE SIZES
5.16.0 5562 109 1077 80 20504 2702 8750 2375 4815 152
5.18.0 5892 113 1088 79 20077 2760 9365 2439 4943 154
5.20.0 6243 115 1187 75 19499 2701 9620 2457 5145 159
- 5.22.0 7819 115 1284 77 19121 2635 9772 2434 5615 176
The "core"..."doc" mean the following files from the Perl source code
distribution. The glob notation ** means recursively, (.) means
======================================================================
- 5.20.0 5.22.0
-
- Configure 552 1 570 1
- Cross 118 15 118 15
- djgpp 18 7 17 7
- h2pl 13 15 13 15
- hints 355 90 356 87
- mad 174 8 - -
- NetWare 467 61 466 61
- os2 510 70 510 70
- plan9 316 17 317 17
- Porting 1204 68 1393 71
- qnx 1 4 1 4
- symbian 290 54 291 54
- utils 241 27 242 27
- vms 538 12 532 12
- vos 8 7 8 7
- win32 1183 64 1201 64
- x2p 341 19 - -
+ 5.20.0
+
+ Configure 552 1
+ Cross 118 15
+ NetWare 467 61
+ Porting 1204 68
+ djgpp 18 7
+ h2pl 13 15
+ hints 355 90
+ mad 174 8
+ os2 510 70
+ plan9 316 17
+ qnx 1 4
+ symbian 290 54
+ utils 241 27
+ vms 538 12
+ vos 8 7
+ win32 1183 64
+ x2p 341 19
=head2 SELECTED PATCH SIZES
{
PerlIOl * next; /* Lower layer */
PerlIO_funcs * tab; /* Functions for this layer */
- U32 flags; /* Various flags for state */
+ IV flags; /* Various flags for state */
};
A C<PerlIOl *> is a pointer to the struct, and the I<application>
$shucks++;
die "Somebody sent me a SIG$signame";
}
- $SIG{INT} = __PACKAGE__ . "::catch_zap";
+ $SIG{INT} = __PACKAGE__ . "::catch_zap";
$SIG{INT} = \&catch_zap; # best strategy
Prior to Perl 5.8.0 it was necessary to do as little as you possibly
Sending a signal to a negative process ID means that you send the signal
to the entire Unix process group. This code sends a hang-up signal to all
-processes in the current process group, and also sets $SIG{HUP} to C<"IGNORE">
+processes in the current process group, and also sets $SIG{HUP} to C<"IGNORE">
so it doesn't kill itself:
# block scope for local
located in the subroutine C<code()>, which just prints some debugging
info to show that it works; it should be replaced with the real code.
- #!/usr/bin/perl
-
- use strict;
- use warnings;
+ #!/usr/bin/perl -w
use POSIX ();
use FindBin ();
use File::Basename ();
- use File::Spec::Functions qw(catfile);
+ use File::Spec::Functions;
$| = 1;
print "PID: $$\n";
print "ARGV: @ARGV\n";
my $count = 0;
- while (1) {
+ while (++$count) {
sleep 2;
- print ++$count, "\n";
+ print "$count\n";
}
}
opcode (e.g. a regular expression operation on a very large string) will
not be seen until the current opcode completes.
-If a signal of any given type fires multiple times during an opcode
+If a signal of any given type fires multiple times during an opcode
(such as from a fine-grained timer), the handler for that signal will
be called only once, after the opcode completes; all other
instances will be discarded. Furthermore, if your system's signal queue
SA_RESTART flag when installing %SIG handlers. This meant that
restartable system calls would continue rather than returning when
a signal arrived. In order to deliver deferred signals promptly,
-Perl 5.8.0 and later do I<not> use SA_RESTART. Consequently,
+Perl 5.8.0 and later do I<not> use SA_RESTART. Consequently,
restartable system calls can fail (with $! set to C<EINTR>) in places
where they previously would have succeeded.
The default C<:perlio> layer retries C<read>, C<write>
-and C<close> as described above; interrupted C<wait> and
+and C<close> as described above; interrupted C<wait> and
C<waitpid> calls will always be retried.
=item Signals as "faults"
to handle. Consider:
open(FH, "|bogus") || die "can't fork: $!";
- print FH "bang\n"; # neither necessary nor sufficient
+ print FH "bang\n"; # neither necessary nor sufficient
# to check print retval!
close(FH) || die "can't close: $!";
system doesn't have the setsid() function, open F</dev/tty> and use the
C<TIOCNOTTY> ioctl() on it instead. See tty(4) for details.
-Non-Unix users should check their C<< I<Your_OS>::Process >> module for
+Non-Unix users should check their C<< I<Your_OS>::Process >> module for
other possible solutions.
=head2 Safe Pipe Opens
}
} until defined $pid;
- if ($pid) { # I am the parent
+ if ($pid) { # I am the parent
print KID_TO_WRITE @some_data;
close(KID_TO_WRITE) || warn "kid exited $?";
} else { # I am the child
# drop permissions in setuid and/or setgid programs:
- ($EUID, $EGID) = ($UID, $GID);
- open (OUTFILE, "> $PRECIOUS")
+ ($EUID, $EGID) = ($UID, $GID);
+ open (OUTFILE, "> $PRECIOUS")
|| die "can't open $PRECIOUS: $!";
while (<STDIN>) {
print OUTFILE; # child's STDIN is parent's KID_TO_WRITE
}
It is very easy to dead-lock a process using this form of open(), or
-indeed with any use of pipe() with multiple subprocesses. The
+indeed with any use of pipe() with multiple subprocesses. The
example above is "safe" because it is simple and calls exec(). See
L</"Avoiding Pipe Deadlocks"> for general safety principles, but there
are extra gotchas with Safe Pipe Opens.
One would use either of these:
- open(PS_PIPE, "-|", "ps", "aux")
+ open(PS_PIPE, "-|", "ps", "aux")
|| die "can't open ps pipe: $!";
@ps_args = qw[ ps aux ];
Because there are more than three arguments to open(), forks the ps(1)
command I<without> spawning a shell, and reads its standard output via the
C<PS_PIPE> filehandle. The corresponding syntax to I<write> to command
-pipes is to use C<"|-"> in place of C<"-|">.
+pipes is to use C<"|-"> in place of C<"-|">.
This was admittedly a rather silly example, because you're using string
literals whose content is perfectly safe. There is therefore no cause to
=for TODO
Hold on, is this even true? First it says that socketpair() is avoided
-for portability, but then it says it probably won't work except on
+for portability, but then it says it probably won't work except on
Unixy systems anyway. Which one of those is true?
Here's an example of using open2():
PARENT_WTR->autoflush(1);
if ($pid = fork()) {
- close PARENT_RDR;
+ close PARENT_RDR;
close PARENT_WTR;
print CHILD_WTR "Parent Pid $$ is sending this\n";
chomp($line = <CHILD_RDR>);
waitpid($pid, 0);
} else {
die "cannot fork: $!" unless defined $pid;
- close CHILD_RDR;
+ close CHILD_RDR;
close CHILD_WTR;
chomp($line = <PARENT_RDR>);
print "Child Pid $$ just read this: '$line'\n";
print PARENT_WTR "Child Pid $$ is sending this\n";
- close PARENT_RDR;
+ close PARENT_RDR;
close PARENT_WTR;
exit(0);
}
One of the major problems with ancient, antemillennial socket code in Perl
was that it used hard-coded values for some of the constants, which
severely hurt portability. If you ever see code that does anything like
-explicitly setting C<$AF_INET = 2>, you know you're in for big trouble.
+explicitly setting C<$AF_INET = 2>, you know you're in for big trouble.
An immeasurably superior approach is to use the C<Socket> module, which more
reliably grants access to the various constants and functions you'll need.
conformant (be strict in what you provide), but they also recommend
accepting a lone "\012" on input (be lenient in what you require).
We haven't always been very good about that in the code in this manpage,
-but unless you're on a Mac from way back in its pre-Unix dark ages, you'll
+but unless you're on a Mac from way back in its pre-Unix dark ages, you'll
probably be ok.
=head2 Internet TCP Clients and Servers
my $proto = getprotobyname("tcp");
socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
- setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
+ setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
|| die "setsockopt: $!";
bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
listen(Server, SOMAXCONN) || die "listen: $!";
my $proto = getprotobyname("tcp");
socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
- setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
+ setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
|| die "setsockopt: $!";
bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
listen(Server, SOMAXCONN) || die "listen: $!";
unless (defined($pid = fork())) {
logmsg "cannot fork: $!";
return;
- }
+ }
elsif ($pid) {
logmsg "begat $pid";
return; # I'm the parent
L</Deferred Signals (Safe Signals)> above) in Perl 5.8.0 means that
accept() might also be interrupted when the process receives a signal.
This typically happens when one of the forked subprocesses exits and
-notifies the parent process with a CHLD signal.
+notifies the parent process with a CHLD signal.
If accept() is interrupted by a signal, $! will be set to EINTR.
If this happens, we can safely continue to the next iteration of
the loop and another call to accept(). It is important that your
-signal handling code not modify the value of $!, or else this test
+signal handling code not modify the value of $!, or else this test
will likely fail. In the REAPER subroutine we create a local version
of $! before calling waitpid(). When waitpid() sets $! to ECHILD as
-it inevitably does when it has no more children waiting, it
+it inevitably does when it has no more children waiting, it
updates the local copy and leaves the original unchanged.
You should use the B<-T> flag to enable taint checking (see L<perlsec>)
printf "%-24s ", $host;
my $hisiaddr = inet_aton($host) || die "unknown host";
my $hispaddr = sockaddr_in($port, $hisiaddr);
- socket(SOCKET, PF_INET, SOCK_STREAM, $proto)
+ socket(SOCKET, PF_INET, SOCK_STREAM, $proto)
|| die "socket: $!";
connect(SOCKET, $hispaddr) || die "connect: $!";
my $rtime = pack("C4", ());
unless (defined($pid = fork())) {
logmsg "cannot fork: $!";
return;
- }
+ }
elsif ($pid) {
logmsg "begat $pid";
return; # I'm the parent
- }
+ }
else {
# I'm the child -- go spawn
}
manpage describes the low-level interface to sockets. Besides the obvious
functions in L<perlfunc>, you should also check out the F<modules> file at
your nearest CPAN site, especially
-L<http://www.cpan.org/modules/00modlist.long.html#ID5_Networking_>.
+L<http://www.cpan.org/modules/00modlist.long.html#ID5_Networking_>.
See L<perlmodlib> or best yet, the F<Perl FAQ> for a description
-of what CPAN is and where to get it if the previous link doesn't work
+of what CPAN is and where to get it if the previous link doesn't work
for you.
Section 5 of CPAN's F<modules> file is devoted to "Networking, Device
=over
-=item Category C<LC_NUMERIC>: Numeric formatting
+=item Category LC_NUMERIC: Numeric formatting
This indicates how numbers should be formatted for human readability,
for example the character used as the decimal point.
-=item Category C<LC_MONETARY>: Formatting of monetary amounts
+=item Category LC_MONETARY: Formatting of monetary amounts
=for comment
The nbsp below makes this look better (though not great)
E<160>
-=item Category C<LC_TIME>: Date/Time formatting
+=item Category LC_TIME: Date/Time formatting
=for comment
The nbsp below makes this look better (though not great)
E<160>
-=item Category C<LC_MESSAGES>: Error and other messages
+=item Category LC_MESSAGES: Error and other messages
This is used by Perl itself only for accessing operating system error
messages via L<$!|perlvar/$ERRNO> and L<$^E|perlvar/$EXTENDED_OS_ERROR>.
-=item Category C<LC_COLLATE>: Collation
+=item Category LC_COLLATE: Collation
This indicates the ordering of letters for comparison and sorting.
In Latin alphabets, for example, "b", generally follows "a".
-=item Category C<LC_CTYPE>: Character Types
+=item Category LC_CTYPE: Character Types
This indicates, for example if a character is an uppercase letter.
XS modules for all categories but C<LC_NUMERIC> get the underlying
locale, and hence any C library functions they call will use that
-underlying locale. For more discussion, see L<perlxs/CAVEATS>.
+underlying locale. Perl always initializes C<LC_NUMERIC> to C<"C">
+because too many modules are unable to cope with the decimal point in a
+floating point number not being a dot (it's a comma in many locales).
+But note that these modules are vulnerable because C<LC_NUMERIC>
+currently can be changed at any time by a call to the C C<set_locale()>
+by XS code or by something XS code calls, or by C<POSIX::setlocale()> by
+Perl code. This is true also for the Perl-provided lite wrappers for XS
+modules to use some C library C<printf> functions:
+C<Gconvert>,
+L<my_sprintf|perlapi/my_sprintf>,
+L<my_snprintf|perlapi/my_snprintf>,
+and
+L<my_vsnprintf|perlapi/my_vsnprintf>.
=back
operands are char-for-char identical. If you really want to know whether
two strings--which C<eq> and C<cmp> may consider different--are equal
as far as collation in the locale is concerned, see the discussion in
-L<Category C<LC_COLLATE>: Collation>.
+L<Category LC_COLLATE: Collation>.
=item *
# restore the old locale
setlocale(LC_CTYPE, $old_locale);
-This simultaneously affects all threads of the program, so it may be
-problematic to use locales in threaded applications except where there
-is a single locale applicable to all threads.
-
The first argument of C<setlocale()> gives the B<category>, the second the
B<locale>. The category tells in what aspect of data processing you
want to apply locale-specific rules. Category names are discussed in
example.
If no second argument is provided and the category is something other
-than C<LC_ALL>, the function returns a string naming the current locale
+than LC_ALL, the function returns a string naming the current locale
for the category. You can use this value as the second argument in a
subsequent call to C<setlocale()>, B<but> on some platforms the string
is opaque, not something that most people would be able to decipher as
to what locale it means.
-If no second argument is provided and the category is C<LC_ALL>, the
+If no second argument is provided and the category is LC_ALL, the
result is implementation-dependent. It may be a string of
concatenated locale names (separator also implementation-dependent)
or a single locale name. Please consult your L<setlocale(3)> man page for
are supported and installed on your system.
perl: warning: Falling back to the standard locale ("C").
-This means that your locale settings had C<LC_ALL> set to "En_US" and
+This means that your locale settings had LC_ALL set to "En_US" and
LANG exists but has no value. Perl tried to believe you but could not.
Instead, Perl gave up and fell back to the "C" locale, the default locale
that is supposed to work no matter what. (On Windows, it first tries
locale inconsistencies or to run Perl under the default locale "C".
Perl's moaning about locale problems can be silenced by setting the
-environment variable C<PERL_BADLANG> to a zero value, for example "0".
+environment variable PERL_BADLANG to a zero value, for example "0".
This method really just sweeps the problem under the carpet: you tell
Perl to shut up even when Perl sees that something is wrong. Do not
be surprised if later something locale-dependent misbehaves.
Perl can be run under the "C" locale by setting the environment
-variable C<LC_ALL> to "C". This method is perhaps a bit more civilized
-than the C<PERL_BADLANG> approach, but setting C<LC_ALL> (or
+variable LC_ALL to "C". This method is perhaps a bit more civilized
+than the PERL_BADLANG approach, but setting LC_ALL (or
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>
for their effects in Perl. Effects in other programs are
-easily deducible. For example, the variable C<LC_COLLATE> may well affect
+easily deducible. For example, the variable LC_COLLATE may well affect
your B<sort> program (or whatever the program that arranges "records"
alphabetically in your system is called).
You can test out changing these variables temporarily, and if the
new settings seem to help, put those settings into your shell startup
-files. Consult your local documentation for the exact details. For
+files. Consult your local documentation for the exact details. For in
Bourne-like shells (B<sh>, B<ksh>, B<bash>, B<zsh>):
LC_ALL=en_US.ISO8859-1
setenv LC_ALL en_US.ISO8859-1
-or if you have the "env" application you can do (in any shell)
+or if you have the "env" application you can do in any shell
env LC_ALL=en_US.ISO8859-1 perl ...
some combination categories allow manipulation of more than one
basic category at a time. See L<"ENVIRONMENT"> for a discussion of these.
-=head2 Category C<LC_COLLATE>: Collation
+=head2 Category LC_COLLATE: Collation
In the scope of S<C<use locale>> (but not a
C<use locale ':not_characters'>), Perl looks to the C<LC_COLLATE>
"color" follows "chocolate" in English, what about in traditional Spanish?
The following collations all make sense and you may meet any of them
-if you C<"use locale">.
+if you "use locale".
A B C D E a b c d e
A a B b C c D d E e
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
+Perl 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.
which use the standard system-supplied C<libc> functions that
always obey the current C<LC_COLLATE> locale.
-=head2 Category C<LC_CTYPE>: Character Types
+=head2 Category LC_CTYPE: Character Types
In the scope of S<C<use locale>> (but not a
C<use locale ':not_characters'>), Perl obeys the C<LC_CTYPE> locale
The C<LC_CTYPE> locale also provides the map used in transliterating
characters between lower and uppercase. This affects the case-mapping
-functions--C<fc()>, C<lc()>, C<lcfirst()>, C<uc()>, and C<ucfirst()>;
-case-mapping
+functions--C<fc()>, C<lc()>, C<lcfirst()>, C<uc()>, and C<ucfirst()>; case-mapping
interpolation with C<\F>, C<\l>, C<\L>, C<\u>, or C<\U> in double-quoted
strings and C<s///> substitutions; and case-independent regular expression
pattern matching using the C<i> modifier.
Finally, C<LC_CTYPE> affects the (deprecated) POSIX character-class test
functions--C<POSIX::isalpha()>, C<POSIX::islower()>, and so on. For
-example, if you move from the "C" locale to a 7-bit ISO 646 one,
-you may find--possibly to your surprise--that C<"|"> moves from the
+example, if you move from the "C" locale to a 7-bit Scandinavian one,
+you may find--possibly to your surprise--that "|" moves from the
C<POSIX::ispunct()> class to C<POSIX::isalpha()>.
Unfortunately, this creates big problems for regular expressions. "|" still
means alternation even though it matches C<\w>.
Starting in v5.20, Perl supports UTF-8 locales for C<LC_CTYPE>, but
otherwise Perl only supports single-byte locales, such as the ISO 8859
series. This means that wide character locales, for example for Asian
-languages, are not well-supported. The UTF-8 locale support is actually a
+languages, are not supported. The UTF-8 locale support is actually a
superset of POSIX locales, because it is really full Unicode behavior
as if no locale were in effect at all (except for tainting; see
L</SECURITY>). POSIX locales, even UTF-8 ones,
used as a workaround for this (see L</Unicode and UTF-8>).
Note that there are quite a few things that are unaffected by the
-current locale. Any literal character is the native character for the
-given platform. Hence 'A' means the character at code point 65 on ASCII
-platforms, and 193 on EBCDIC. That may or may not be an 'A' in the
-current locale, if that locale even has an 'A'.
-Similarly, all the escape sequences for particular characters,
+current locale. All the escape sequences for particular characters,
C<\n> for example, always mean the platform's native one. This means,
for example, that C<\N> in regular expressions (every character
but new-line) works on the platform character set.
digits--for example, in command strings--locale-aware applications
should use C<\w> with the C</a> regular expression modifier. See L<"SECURITY">.
-=head2 Category C<LC_NUMERIC>: Numeric Formatting
+=head2 Category LC_NUMERIC: Numeric Formatting
After a proper C<POSIX::setlocale()> call, and within the scope of one
of the C<use locale> variants, Perl obeys the C<LC_NUMERIC>
See also L<I18N::Langinfo> and C<RADIXCHAR>.
-=head2 Category C<LC_MONETARY>: Formatting of monetary amounts
+=head2 Category LC_MONETARY: Formatting of monetary amounts
The C standard defines the C<LC_MONETARY> category, but not a function
that is affected by its contents. (Those with experience of standards
See also L<I18N::Langinfo> and C<CRNCYSTR>.
-=head2 C<LC_TIME>
+=head2 LC_TIME
Output produced by C<POSIX::strftime()>, which builds a formatted
human-readable date/time string, is affected by the current C<LC_TIME>
Regular expression checks for safe file names or mail addresses using
C<\w> may be spoofed by an C<LC_CTYPE> locale that claims that
-characters such as C<"E<gt>"> and C<"|"> are alphanumeric.
+characters such as "E<gt>" and "|" are alphanumeric.
=item *
String interpolation with case-mapping, as in, say, C<$dest =
-"C:\U$name.$ext">, may produce dangerous results if a bogus C<LC_CTYPE>
+"C:\U$name.$ext">, may produce dangerous results if a bogus LC_CTYPE
case-mapping table is in effect.
=item *
zero--that is, "0" or ""-- Perl will complain about locale setting
failures.
-B<NOTE>: C<PERL_BADLANG> only gives you a way to hide the warning message.
+B<NOTE>: PERL_BADLANG only gives you a way to hide the warning message.
The message tells about some problem in your system's locale support,
and you should investigate what the problem is.
the next lower one in priority. If none are valid, on Windows, the
system default locale is then tried. If all else fails, the C<"C">
locale is used. If even that doesn't work, something is badly broken,
-but Perl tries to forge ahead with whatever the locale settings might
+but Perl tries to forge ahead with whatever the locale settinga might
be.
=over 12
-=item C<LC_ALL>
+=item LC_ALL
C<LC_ALL> is the "override-all" locale environment variable. If
set, it overrides all the rest of the locale environment variables.
-=item C<LANGUAGE>
+=item LANGUAGE
B<NOTE>: C<LANGUAGE> is a GNU extension, it affects you only if you
are using the GNU libc. This is the case if you are using e.g. Linux.
instead a "path" (":"-separated list) of I<languages> (not locales).
See the GNU C<gettext> library documentation for more information.
-=item C<LC_CTYPE>.
+=item LC_CTYPE
In the absence of C<LC_ALL>, C<LC_CTYPE> chooses the character type
locale. In the absence of both C<LC_ALL> and C<LC_CTYPE>, C<LANG>
chooses the character type locale.
-=item C<LC_COLLATE>
+=item LC_COLLATE
In the absence of C<LC_ALL>, C<LC_COLLATE> chooses the collation
(sorting) locale. In the absence of both C<LC_ALL> and C<LC_COLLATE>,
C<LANG> chooses the collation locale.
-=item C<LC_MONETARY>
+=item LC_MONETARY
In the absence of C<LC_ALL>, C<LC_MONETARY> chooses the monetary
formatting locale. In the absence of both C<LC_ALL> and C<LC_MONETARY>,
C<LANG> chooses the monetary formatting locale.
-=item C<LC_NUMERIC>
+=item LC_NUMERIC
In the absence of C<LC_ALL>, C<LC_NUMERIC> chooses the numeric format
locale. In the absence of both C<LC_ALL> and C<LC_NUMERIC>, C<LANG>
chooses the numeric format.
-=item C<LC_TIME>
+=item LC_TIME
In the absence of C<LC_ALL>, C<LC_TIME> chooses the date and time
formatting locale. In the absence of both C<LC_ALL> and C<LC_TIME>,
C<LANG> chooses the date and time formatting locale.
-=item C<LANG>
+=item LANG
C<LANG> is the "catch-all" locale environment variable. If it is set, it
is used as the last resort after the overall C<LC_ALL> and the
-category-specific C<LC_I<foo>>
+category-specific C<LC_...>.
=back
=head2 Examples
-The C<LC_NUMERIC> controls the numeric output:
+The LC_NUMERIC controls the numeric output:
use locale;
use POSIX qw(locale_h); # Imports setlocale() and the LC_ constants.
they and Perl store characters that take up multiple bytes the same way.
However, some, if not most, C library implementations may not process
the characters in the upper half of the Latin-1 range (128 - 255)
-properly under C<LC_CTYPE>. To see if a character is a particular type
+properly under LC_CTYPE. To see if a character is a particular type
under a locale, Perl uses the functions like C<isalnum()>. Your C
library may not work for UTF-8 locales with those functions, instead
-only working under the newer wide library functions like C<iswalnum()>,
-which Perl does not use.
-These multi-byte locales are treated like single-byte locales, and will
-have the restrictions described below.
+only working under the newer wide library functions like C<iswalnum()>.
+However, they are treated like single-byte locales, and will have the
+restrictions described below.
For single-byte locales,
Perl generally takes the tack to use locale rules on code points that can fit
issue occurs with C<\N{...}>. Prior to v5.20, It is therefore a bad
idea to use C<\p{}> or
C<\N{}> under plain C<use locale>--I<unless> you can guarantee that the
-locale will be ISO8859-1. Use POSIX character classes instead.
+locale will be a ISO8859-1. Use POSIX character classes instead.
Another problem with this approach is that operations that cross the
single byte/multiple byte boundary are not well-defined, and so are
Pre-v5.12, it was somewhat haphazard; in v5.12 it was applied fairly
consistently to regular expression matching except for bracketed
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.
+v5.16 to the casing operations such as C<"\L"> and C<uc()>. For
+collation, in all releases, the system's C<strxfrm()> function is called,
+and whatever it does is what you get.
=head1 BUGS
=head1 DESCRIPTION
-=head2 Is this the document you were after?
-
-There are other documents which might contain the information that you're
-looking for:
-
-=over 2
-
-=item This doc
-
-Perl's packages, namespaces, and some info on classes.
-
-=item L<perlnewmod>
-
-Tutorial on making a new module.
-
-=item L<perlmodstyle>
-
-Best practices for making a new module.
-
-=back
-
=head2 Packages
X<package> X<namespace> X<variable, global> X<global variable> X<global>
good reason.
Good places to look for pre-existing modules include
-L<http://search.cpan.org/> and L<https://metacpan.org>
-and asking on C<module-authors@perl.org>
-(L<http://lists.perl.org/list/module-authors.html>).
+http://search.cpan.org/ and asking on modules@perl.org
If an existing module B<almost> does what you want, consider writing a
patch, writing a subclass, or otherwise extending the existing module
=item Parameter passing
-Use named parameters. It's easier to use a hash like this:
+Use named parameters. It's easier to use a hash like this:
$obj->do_something(
name => "wibble",
giving pointers to further information (website, author email).
An INSTALL file should be included, and should contain simple installation
-instructions. When using ExtUtils::MakeMaker this will usually be:
+instructions. When using ExtUtils::MakeMaker this will usually be:
=over 4
1.00, 1.10, 1.11, 1.20, 1.30, 1.31, 1.32
A correct CPAN version number is a floating point number with at least
-2 digits after the decimal. You can test whether it conforms to CPAN by
+2 digits after the decimal. You can test whether it conforms to CPAN by
using
perl -MExtUtils::MakeMaker -le 'print MM->parse_version(shift)' 'Foo.pm'
If you want to release a 'beta' or 'alpha' version of a module but
don't want CPAN.pm to list it as most recent use an '_' after the
-regular version number followed by at least 2 digits, eg. 1.20_01. If
+regular version number followed by at least 2 digits, eg. 1.20_01. If
you do this, the following idiom is recommended:
- our $VERSION = "1.12_01"; # so CPAN distribution will have
- # right filename
- our $XS_VERSION = $VERSION; # only needed if you have XS code
- $VERSION = eval $VERSION; # so "use Module 0.002" won't warn on
- # underscore
+ $VERSION = "1.12_01";
+ $XS_VERSION = $VERSION; # only needed if you have XS code
+ $VERSION = eval $VERSION;
With that trick MakeMaker will only read the first line and thus read
the underscore, while the perl interpreter will evaluate the $VERSION
-and convert the string into a number. Later operations that treat
+and convert the string into a number. Later operations that treat
$VERSION as a number will then be able to do so without provoking a
warning about $VERSION not being a number.
incrementing the number. Even a one-word documentation patch should
result in a change in version at the sub-minor level.
-Once picked, it is important to stick to your version scheme, without
-reducing the number of digits. This is because "downstream" packagers,
-such as the FreeBSD ports system, interpret the version numbers in
-various ways. If you change the number of digits in your version scheme,
-you can confuse these systems so they get the versions of your module
-out of order, which is obviously bad.
-
=head2 Pre-requisites
Module authors should carefully consider whether to rely on other
pre-requisites in your Makefile.PL or Build.PL.
Be sure to specify Perl version requirements both in Makefile.PL or
-Build.PL and with C<require 5.6.1> or similar. See the section on
+Build.PL and with C<require 5.6.1> or similar. See the section on
C<use VERSION> of L<perlfunc/require> for details.
=head2 Testing
For Module::Build you would use the C<make test> equivalent C<perl Build test>.
The importance of these tests is proportional to the alleged stability of a
-module. A module which purports to be
-stable or which hopes to achieve wide
+module. A module which purports to be stable or which hopes to achieve wide
use should adhere to as strict a testing regime as possible.
Useful modules to help you write tests (with minimum impact on your
more platform independent Module::Build, allowing modules to be installed in a
consistent manner.
When using ExtUtils::MakeMaker, you can use "make dist" to create your
-package. Tools exist to help you to build your module in a
-MakeMaker-friendly style. These include ExtUtils::ModuleMaker and h2xs.
-See also L<perlnewmod>.
+package. Tools exist to help you to build your module in a MakeMaker-friendly
+style. These include ExtUtils::ModuleMaker and h2xs. See also L<perlnewmod>.
=head2 Licensing
packaging up the solution into a module and uploading it to CPAN so that
others can benefit.
-You should also take a look at L<perlmodstyle> for best practices in
-making a module.
-
=head2 Warning
We're going to primarily concentrate on Perl-only modules here, rather
=head1 DESCRIPTION
In Perl, the operator determines what operation is performed,
-independent of the type of the operands. For example C<$x + $y>
-is always a numeric addition, and if C<$x> or C<$y> do not contain
+independent of the type of the operands. For example C<$a + $b>
+is always a numeric addition, and if C<$a> or C<$b> do not contain
numbers, an attempt is made to convert them to numbers first.
This is in contrast to many other dynamic languages, where the
-operation is determined by the type of the first argument. It also
+operation is determined by the type of the first argument. It also
means that Perl has two versions of some operators, one for numeric
-and one for string comparison. For example C<$x == $y> compares
-two numbers for equality, and C<$x eq $y> compares two strings.
+and one for string comparison. For example C<$a == $b> compares
+two numbers for equality, and C<$a eq $b> compares two strings.
There are a few exceptions though: C<x> can be either string
repetition or list repetition, depending on the type of the left
print ++$j; # prints 1
Note that just as in C, Perl doesn't define B<when> the variable is
-incremented or decremented. You just know it will be done sometime
-before or after the value is returned. This also means that modifying
+incremented or decremented. You just know it will be done sometime
+before or after the value is returned. This also means that modifying
a variable twice in the same statement will lead to undefined behavior.
Avoid statements like:
X<**> X<exponentiation> X<power>
Binary "**" is the exponentiation operator. It binds even more
-tightly than unary minus, so -2**4 is -(2**4), not (-2)**4. (This is
+tightly than unary minus, so -2**4 is -(2**4), not (-2)**4. (This is
implemented using C's pow(3) function, which actually works on doubles
internally.)
returned. One effect of these rules is that -bareword is equivalent
to the string "-bareword". If, however, the string begins with a
non-alphabetic character (excluding "+" or "-"), Perl will attempt to convert
-the string to a numeric and the arithmetic negation is performed. If the
+the string to a numeric and the arithmetic negation is performed. If the
string cannot be cleanly converted to a numeric, Perl will give the warning
B<Argument "the string" isn't numeric in negation (-) at ...>.
X<-> X<negation, arithmetic>
If the right argument is an expression rather than a search pattern,
substitution, or transliteration, it is interpreted as a search pattern at run
-time. Note that this means that its
-contents will be interpolated twice, so
+time. Note that this means that its contents will be interpolated twice, so
'\\' =~ q'\\';
Binary "%" is the modulo operator, which computes the division
remainder of its first argument with respect to its second argument.
Given integer
-operands C<$m> and C<$n>: If C<$n> is positive, then C<$m % $n> is
-C<$m> minus the largest multiple of C<$n> less than or equal to
-C<$m>. If C<$n> is negative, then C<$m % $n> is C<$m> minus the
-smallest multiple of C<$n> that is not less than C<$m> (that is, the
+operands C<$a> and C<$b>: If C<$b> is positive, then C<$a % $b> is
+C<$a> minus the largest multiple of C<$b> less than or equal to
+C<$a>. If C<$b> is negative, then C<$a % $b> is C<$a> minus the
+smallest multiple of C<$b> that is not less than C<$a> (that is, the
result will be less than or equal to zero). If the operands
-C<$m> and C<$n> are floating point values and the absolute value of
-C<$n> (that is C<abs($n)>) is less than C<(UV_MAX + 1)>, only
-the integer portion of C<$m> and C<$n> will be used in the operation
+C<$a> and C<$b> are floating point values and the absolute value of
+C<$b> (that is C<abs($b)>) is less than C<(UV_MAX + 1)>, only
+the integer portion of C<$a> and C<$b> will be used in the operation
(Note: here C<UV_MAX> means the maximum of the unsigned integer type).
-If the absolute value of the right operand (C<abs($n)>) is greater than
+If the absolute value of the right operand (C<abs($b)>) is greater than
or equal to C<(UV_MAX + 1)>, "%" computes the floating-point remainder
-C<$r> in the equation C<($r = $m - $i*$n)> where C<$i> is a certain
+C<$r> in the equation C<($r = $a - $i*$b)> where C<$i> is a certain
integer that makes C<$r> have the same sign as the right operand
-C<$n> (B<not> as the left operand C<$m> like C function C<fmod()>)
-and the absolute value less than that of C<$n>.
+C<$b> (B<not> as the left operand C<$a> like C function C<fmod()>)
+and the absolute value less than that of C<$b>.
Note that when C<use integer> is in scope, "%" gives you direct access
to the modulo operator as implemented by your C compiler. This
operator is not as well defined for negative operands, but it will
argument is numerically less than, equal to, or greater than the right
argument. If your platform supports NaNs (not-a-numbers) as numeric
values, using them with "<=>" returns undef. NaN is not "<", "==", ">",
-"<=" or ">=" anything (even NaN), so those 5 return false. NaN != NaN
-returns true, as does NaN != anything else. If your platform doesn't
+"<=" or ">=" anything (even NaN), so those 5 return false. NaN != NaN
+returns true, as does NaN != anything else. If your platform doesn't
support NaNs then NaN is just a string with numeric value 0.
X<< <=> >> X<spaceship>
- $ perl -le '$x = "NaN"; print "No NaN support here" if $x == $x'
- $ perl -le '$x = "NaN"; print "NaN support here" if $x != $x'
+ $ perl -le '$a = "NaN"; print "No NaN support here" if $a == $a'
+ $ perl -le '$a = "NaN"; print "NaN support here" if $a != $a'
-(Note that the L<bigint>, L<bigrat>, and L<bignum> pragmas all
+(Note that the L<bigint>, L<bigrat>, and L<bignum> pragmas all
support "NaN".)
Binary "eq" returns true if the left argument is stringwise equal to
(eventually) has a 4 in it.
Smartmatching one hash against another reports whether both contain the
-same keys, no more and no less. This could be used to see whether two
+same keys, no more and no less. This could be used to see whether two
records have the same field names, without caring what values those fields
might have. For example:
To avoid relying on an object's underlying representation, if the
smartmatch's right operand is an object that doesn't overload C<~~>,
it raises the exception "C<Smartmatching a non-overloaded object
-breaks encapsulation>". That's because one has no business digging
-around to see whether something is "in" an object. These are all
+breaks encapsulation>". That's because one has no business digging
+around to see whether something is "in" an object. These are all
illegal on objects without a C<~~> overload:
%hash ~~ $object
"fred" ~~ $object
However, you can change the way an object is smartmatched by overloading
-the C<~~> operator. This is allowed to
-extend the usual smartmatch semantics.
+the C<~~> operator. This is allowed to extend the usual smartmatch semantics.
For objects that do have an C<~~> overload, see L<overload>.
Using an object as the left operand is allowed, although not very useful.
to its C-style or. In fact, it's exactly the same as C<||>, except that it
tests the left hand side's definedness instead of its truth. Thus,
C<< EXPR1 // EXPR2 >> returns the value of C<< EXPR1 >> if it's defined,
-otherwise, the value of C<< EXPR2 >> is returned.
-(C<< EXPR1 >> is evaluated in scalar context, C<< EXPR2 >>
-in the context of C<< // >> itself). Usually,
+otherwise, the value of C<< EXPR2 >> is returned. (C<< EXPR1 >> is evaluated
+in scalar context, C<< EXPR2 >> in the context of C<< // >> itself). Usually,
this is the same result as C<< defined(EXPR1) ? EXPR1 : EXPR2 >> (except that
the ternary-operator form can be used as a lvalue, while C<< EXPR1 // EXPR2 >>
-cannot). This is very useful for
+cannot). This is very useful for
providing default values for variables. If you actually want to test if
-at least one of C<$x> and C<$y> is defined, use C<defined($x // $y)>.
+at least one of C<$a> and C<$b> is defined, use C<defined($a // $b)>.
The C<||>, C<//> and C<&&> operators return the last value evaluated
-(unlike C's C<||> and C<&&>, which return 0 or 1). Thus, a reasonably
+(unlike C's C<||> and C<&&>, which return 0 or 1). Thus, a reasonably
portable way to find out the home directory might be:
$home = $ENV{HOME}
list of values counting (up by ones) from the left value to the right
value. If the left value is greater than the right value then it
returns the empty list. The range operator is useful for writing
-C<foreach (1..10)> loops and for doing slice operations on arrays. In
+C<foreach (1..10)> loops and for doing slice operations on arrays. In
the current implementation, no temporary array is created when the
range operator is used as the expression in C<foreach> loops, but older
versions of Perl might burn a lot of memory when you write something
In scalar context, ".." returns a boolean value. The operator is
bistable, like a flip-flop, and emulates the line-range (comma)
-operator of B<sed>, B<awk>, and various editors. Each ".." operator
+operator of B<sed>, B<awk>, and various editors. Each ".." operator
maintains its own boolean state, even across calls to a subroutine
-that contains it. It is false as long as its left operand is false.
+that contains it. It is false as long as its left operand is false.
Once the left operand is true, the range operator stays true until the
right operand is true, I<AFTER> which the range operator becomes false
again. It doesn't become false till the next time the range operator
is evaluated. It can test the right operand and become false on the
same evaluation it became true (as in B<awk>), but it still returns
-true once. If you don't want it to test the right operand until the
+true once. If you don't want it to test the right operand until the
next evaluation, as in B<sed>, just use three dots ("...") instead of
two. In all other regards, "..." behaves just like ".." does.
}
}
-This program will print only the line containing "Bar". If
+This program will print only the line containing "Bar". If
the range operator is changed to C<...>, it will also print the
"Baz" line.
Scalar or list context propagates downward into the 2nd
or 3rd argument, whichever is selected.
- $x = $ok ? $y : $z; # get a scalar
- @x = $ok ? @y : @z; # get an array
- $x = $ok ? @y : @z; # oops, that's just a count!
+ $a = $ok ? $b : $c; # get a scalar
+ @a = $ok ? @b : @c; # get an array
+ $a = $ok ? @b : @c; # oops, that's just a count!
The operator may be assigned to if both the 2nd and 3rd arguments are
legal lvalues (meaning that you can assign to them):
- ($x_or_y ? $x : $y) = $z;
+ ($a_or_b ? $a : $b) = $c;
Because this operator produces an assignable result, using assignments
without parentheses will get you in trouble. For example, this:
- $x % 2 ? $x += 10 : $x += 2
+ $a % 2 ? $a += 10 : $a += 2
Really means this:
- (($x % 2) ? ($x += 10) : $x) += 2
+ (($a % 2) ? ($a += 10) : $a) += 2
Rather than this:
- ($x % 2) ? ($x += 10) : ($x += 2)
+ ($a % 2) ? ($a += 10) : ($a += 2)
That should probably be written more simply as:
- $x += ($x % 2) ? 10 : 2;
+ $a += ($a % 2) ? 10 : 2;
=head2 Assignment Operators
X<assignment> X<operator, assignment> X<=> X<**=> X<+=> X<*=> X<&=>
Assignment operators work as in C. That is,
- $x += 2;
+ $a += 2;
is equivalent to
- $x = $x + 2;
+ $a = $a + 2;
although without duplicating any side effects that dereferencing the lvalue
might trigger, such as from tie(). Other assignment operators work similarly.
Likewise,
- ($x += 2) *= 3;
+ ($a += 2) *= 3;
is equivalent to
- $x += 2;
- $x *= 3;
+ $a += 2;
+ $a *= 3;
Similarly, a list assignment in list context produces the list of
lvalues assigned to, and a list assignment in scalar context returns
word on its left to be interpreted as a string if it begins with a letter
or underscore and is composed only of letters, digits and underscores.
This includes operands that might otherwise be interpreted as operators,
-constants, single number v-strings or function calls. If in doubt about
+constants, single number v-strings or function calls. If in doubt about
this behavior, the left operand can be quoted explicitly.
Otherwise, the C<< => >> operator behaves exactly as the comma operator
be careful to avoid using it as replacement for the C<||> operator.
It usually works out better for flow control than in assignments:
- $x = $y or $z; # bug: this is wrong
- ($x = $y) or $z; # really means this
- $x = $y || $z; # better written this way
+ $a = $b or $c; # bug: this is wrong
+ ($a = $b) or $c; # really means this
+ $a = $b || $c; # better written this way
However, when it's a list-context assignment and you're trying to use
C<||> for control flow, you probably need "or" so that the assignment
=item unary *
-Dereference-address operator. (Perl's prefix dereferencing
+Dereference-address operator. (Perl's prefix dereferencing
operators are typed: $, @, %, and &.)
=item (TYPE)
Note, however, that this does not always work for quoting Perl code:
- $s = q{ if($x eq "}") ... }; # WRONG
+ $s = q{ if($a eq "}") ... }; # WRONG
-is a syntax error. The C<Text::Balanced> module (standard as of v5.8,
+is a syntax error. The C<Text::Balanced> module (standard as of v5.8,
and from CPAN before then) is able to do this properly.
There can be whitespace between the operator and the quoting
The result is the character specified by the hexadecimal number between
the braces. See L</[8]> below for details on which character.
-Only hexadecimal digits are valid between the braces. If an invalid
+Only hexadecimal digits are valid between the braces. If an invalid
character is encountered, a warning will be issued and the invalid
character and all subsequent characters (valid or invalid) within the
braces will be discarded.
\c[ chr(27)
\c] chr(29)
\c^ chr(30)
- \c_ chr(31)
- \c? chr(127) # (on ASCII platforms)
+ \c? chr(127)
In other words, it's the character whose code point has had 64 xor'd with
-its uppercase. C<\c?> is DELETE on ASCII platforms because
-S<C<ord("?") ^ 64>> is 127, and
+its uppercase. C<\c?> is DELETE because C<ord("?") ^ 64> is 127, and
C<\c@> is NULL because the ord of "@" is 64, so xor'ing 64 itself produces 0.
Also, C<\c\I<X>> yields C< chr(28) . "I<X>"> for any I<X>, but cannot come at the
On ASCII platforms, the resulting characters from the list above are the
complete set of ASCII controls. This isn't the case on EBCDIC platforms; see
-L<perlebcdic/OPERATOR DIFFERENCES> for a full discussion of the
-differences between these for ASCII versus EBCDIC platforms.
+L<perlebcdic/OPERATOR DIFFERENCES> for the complete list of what these
+sequences mean on both ASCII and EBCDIC platforms.
-Use of any other character following the C<"c"> besides those listed above is
+Use of any other character following the "c" besides those listed above is
discouraged, and some are deprecated with the intention of removing
those in a later Perl version. What happens for any of these
other characters currently though, is that the value is derived by xor'ing
C<\o{}>, or convert to something else, such as to hex and use C<\x{}>
instead.
+Having fewer than 3 digits may lead to a misleading warning message that says
+that what follows is ignored. For example, C<"\128"> in the ASCII character set
+is equivalent to the two characters C<"\n8">, but the warning C<Illegal octal
+digit '8' ignored> will be thrown. If C<"\n8"> is what you want, you can
+avoid this warning by padding your octal number with C<0>'s: C<"\0128">.
+
=item [8]
Several constructs above specify a character by a number. That number
For the pattern of regex operators (C<qr//>, C<m//> and C<s///>),
the quoting from C<\Q> is applied after interpolation is processed,
-but before escapes are processed. This allows the pattern to match
-literally (except for C<$> and C<@>). For example, the following matches:
+but before escapes are processed. This allows the pattern to match
+literally (except for C<$> and C<@>). For example, the following matches:
'\s\t' =~ /\Q\s\t/
expression. I<STRING> is interpolated the same way as I<PATTERN>
in C<m/PATTERN/>. If "'" is used as the delimiter, no interpolation
is done. Returns a Perl value which may be used instead of the
-corresponding C</STRING/msixpodual> expression. The returned value is a
-normalized version of the original pattern. It magically differs from
+corresponding C</STRING/msixpodual> expression. The returned value is a
+normalized version of the original pattern. It magically differs from
a string containing the same characters: C<ref(qr/x/)> returns "Regexp";
however, dereferencing it is not well defined (you currently get the
normalized version of the original pattern, but this may change).
as delimiters. This is particularly useful for matching path names
that contain "/", to avoid LTS (leaning toothpick syndrome). If "?" is
the delimiter, then a match-only-once rule applies,
-described in C<m?PATTERN?> below. If "'" (single quote) is the delimiter,
+described in C<m?PATTERN?> below. If "'" (single quote) is the delimiter,
no interpolation is performed on the PATTERN.
When using a character valid in an identifier, whitespace is required
after the C<m>.
after the trailing delimiter.
Once upon a time, Perl would recompile regular expressions
unnecessarily, and this modifier was useful to tell it not to do so, in the
-interests of speed. But now, the only reasons to use C</o> are one of:
+interests of speed. But now, the only reasons to use C</o> are either:
=over
=item The empty pattern //
If the PATTERN evaluates to the empty string, the last
-I<successfully> matched regular expression is used instead. In this
+I<successfully> matched regular expression is used instead. In this
case, only the C<g> and C<c> flags on the empty pattern are honored;
-the other flags are taken from the original pattern. If no match has
+the other flags are taken from the original pattern. If no match has
previously succeeded, this will (silently) act instead as a genuine
empty pattern (which will always match).
Note that it's possible to confuse Perl into thinking C<//> (the empty
regex) is really C<//> (the defined-or operator). Perl is usually pretty
good about this, but some pathological cases might trigger this, such as
-C<$
x///> (is that C<($x) / (//)> or C<$x // />?) and C<print $fh //>
+C<$
a///> (is that C<($a) / (//)> or C<$a // />?) and C<print $fh //>
(C<print $fh(//> or C<print($fh //>?). In all of these examples, Perl
will assume you meant defined-or. If you meant the empty regex, just
use parentheses or spaces to disambiguate, or even prefix the empty
if the pattern matched.
The C</g> modifier specifies global pattern matching--that is,
-matching as many times as possible within the string. How it behaves
-depends on the context. In list context, it returns a list of the
+matching as many times as possible within the string. How it behaves
+depends on the context. In list context, it returns a list of the
substrings matched by any capturing parentheses in the regular
-expression. If there are no parentheses, it returns a list of all
+expression. If there are no parentheses, it returns a list of all
the matched strings, as if there were parentheses around the whole
pattern.
In scalar context, each execution of C<m//g> finds the next match,
returning true if it matches, and false if there is no further match.
The position after the last match can be read or set using the C<pos()>
-function; see L<perlfunc/pos>. A failed match normally resets the
+function; see L<perlfunc/pos>. A failed match normally resets the
search position to the beginning of the string, but you can avoid that
-by adding the C</c> modifier (for example, C<m//gc>). Modifying the target
+by adding the C</c> modifier (for example, C<m//gc>). Modifying the target
string also resets the search position.
=item \G assertion
You can intermix C<m//g> matches with C<m/\G.../g>, where C<\G> is a
zero-width assertion that matches the exact position where the
-previous C<m//g>, if any, left off. Without the C</g> modifier, the
+previous C<m//g>, if any, left off. Without the C</g> modifier, the
C<\G> assertion still anchors at C<pos()> as it was at the start of
the operation (see L<perlfunc/pos>), but the match is of course only
-attempted once. Using C<\G> without C</g> on a target string that has
+attempted once. Using C<\G> without C</g> on a target string that has
not previously had a C</g> match applied to it is the same as using
the C<\A> assertion to match the beginning of the string. Note also
that, currently, C<\G> is only properly supported when anchored at the
Final: 'q', pos=8
Notice that the final match matched C<q> instead of C<p>, which a match
-without the C<\G> anchor would have done. Also note that the final match
-did not update C<pos>. C<pos> is only updated on a C</g> match. If the
+without the C<\G> anchor would have done. Also note that the final match
+did not update C<pos>. C<pos> is only updated on a C</g> match. If the
final match did indeed match C<p>, it's a good bet that you're running a
very old (pre-5.6.0) version of Perl.
C<s(foo)(bar)> or C<< s<foo>/bar/ >>. A C</e> will cause the
replacement portion to be treated as a full-fledged Perl expression
and evaluated right then and there. It is, however, syntax checked at
-compile-time. A second C<e> modifier will cause the replacement portion
+compile-time. A second C<e> modifier will cause the replacement portion
to be C<eval>ed before being run as a Perl expression.
Examples:
s/^=(\w+)/pod($1)/ge; # use function call
$_ = 'abc123xyz';
- $x = s/abc/def/r; # $x is 'def123xyz' and
+ $a = s/abc/def/r; # $a is 'def123xyz' and
# $_ remains 'abc123xyz'.
# expand variables in $_, but dynamics only, using
specified by SEARCHLIST not found in REPLACEMENTLIST are deleted.
(Note that this is slightly more flexible than the behavior of some
B<tr> programs, which delete anything they find in the SEARCHLIST,
-period.) If the C</s> modifier is specified, sequences of characters
+period.) If the C</s> modifier is specified, sequences of characters
that were transliterated to the same character are squashed down
to a single instance of the character.
=item Single Quotes
Single quotes indicate the text is to be treated literally with no
-interpolation of its content. This is similar to single quoted
+interpolation of its content. This is similar to single quoted
strings except that backslashes have no special meaning, with C<\\>
being treated as two backslashes and not one as they would in every
other quoting construct.
=item Backticks
The content of the here doc is treated just as it would be if the
-string were embedded in backticks. Thus the content is interpolated
+string were embedded in backticks. Thus the content is interpolated
as though it were double quoted and then executed via the shell, with
the results of the execution returned.
outside of string evals.
Additionally, quoting rules for the end-of-string identifier are
-unrelated to Perl's quoting rules. C<q()>, C<qq()>, and the like are not
+unrelated to Perl's quoting rules. C<q()>, C<qq()>, and the like are not
supported in place of C<''> and C<"">, and the only interpolation is for
backslashing the quoting character:
The first pass is finding the end of the quoted construct, where
the information about the delimiters is used in parsing.
During this search, text between the starting and ending delimiters
-is copied to a safe location. The text copied gets delimiter-independent.
+is copied to a safe location. The text copied gets delimiter-independent.
If the construct is a here-doc, the ending delimiter is a line
-that has a terminating string as the content. Therefore C<<<EOF> is
+that has a terminating string as the content. Therefore C<<<EOF> is
terminated by C<EOF> immediately followed by C<"\n"> and starting
from the first column of the terminating line.
When searching for the terminating line of a here-doc, nothing
-is skipped. In other words, lines after the here-doc syntax
+is skipped. In other words, lines after the here-doc syntax
are compared with the terminating string line by line.
For the constructs except here-docs, single characters are used as starting
-and ending delimiters. If the starting delimiter is an opening punctuation
+and ending delimiters. If the starting delimiter is an opening punctuation
(that is C<(>, C<[>, C<{>, or C<< < >>), the ending delimiter is the
corresponding closing punctuation (that is C<)>, C<]>, C<}>, or C<< > >>).
If the starting delimiter is an unpaired character like C</> or a closing
punctuation, the ending delimiter is same as the starting delimiter.
Therefore a C</> terminates a C<qq//> construct, while a C<]> terminates
-both C<qq[]> and C<qq]]> constructs.
+C<qq[]> and C<qq]]> constructs.
When searching for single-character delimiters, escaped delimiters
and C<\\> are skipped. For example, while searching for terminating C</>,
For constructs with three-part delimiters (C<s///>, C<y///>, and
C<tr///>), the search is repeated once more.
-If the first delimiter is not an opening punctuation, the three delimiters must
-be the same, such as C<s!!!> and C<tr)))>,
-in which case the second delimiter
+If the first delimiter is not an opening punctuation, three delimiters must
+be same such as C<s!!!> and C<tr)))>, in which case the second delimiter
terminates the left part and starts the right part at once.
If the left part is delimited by bracketing punctuation (that is C<()>,
C<[]>, C<{}>, or C<< <> >>), the right part needs another pair of
delimiters such as C<s(){}> and C<tr[]//>. In these cases, whitespace
-and comments are allowed between the two parts, though the comment must follow
+and comments are allowed between both parts, though the comment must follow
at least one whitespace character; otherwise a character expected as the
start of the comment may be regarded as the starting delimiter of the right part.
modifier. So the embedded C<#> is interpreted as a literal C<#>.
Also no attention is paid to C<\c\> (multichar control char syntax) during
-this search. Thus the second C<\> in C<qq/\c\/> is interpreted as a part
+this search. Thus the second C<\> in C<qq/\c\/> is interpreted as a part
of C<\/>, and the following C</> is not recognized as a delimiter.
Instead, use C<\034> or C<\x1c> at the end of quoted constructs.
Note also that the interpolation code needs to make a decision on
where the interpolated scalar ends. For instance, whether
-C<< "a $x -> {c}" >> really means:
+C<< "a $b -> {c}" >> really means:
- "a " . $x . " -> {c}";
+ "a " . $b . " -> {c}";
or:
- "a " . $x -> {c};
+ "a " . $b -> {c};
Most of the time, the longest possible text that does not include
spaces between components and which contains matching braces or
except that it isn't so cumbersome to say, and will actually work.
It really does shift the @ARGV array and put the current filename
into the $ARGV variable. It also uses filehandle I<ARGV>
-internally.
<> is just a synonym for <ARGV>, which
+internally. <> is just a synonym for <ARGV>, which
is magical. (The pseudo code above doesn't work because it treats
<ARGV> as non-magical.)
The standard C<Math::BigInt>, C<Math::BigRat>, and C<Math::BigFloat> modules,
along with the C<bignum>, C<bigint>, and C<bigrat> pragmas, provide
variable-precision arithmetic and overloaded operators, although
-they're currently pretty slow. At the cost of some space and
+they're currently pretty slow. At the cost of some space and
considerable speed, they avoid the normal pitfalls associated with
limited-precision representations.
Or with rationals:
- use 5.010;
- use bigrat;
- $x = 3/22;
- $y = 4/6;
- say "x/y is ", $x/$y;
- say "x*y is ", $x*$y;
- x/y is 9/44
- x*y is 1/11
+ use 5.010;
+ use bigrat;
+ $a = 3/22;
+ $b = 4/6;
+ say "a/b is ", $a/$b;
+ say "a*b is ", $a*$b;
+ a/b is 9/44
+ a*b is 1/11
Several modules let you calculate with (bound only by memory and CPU time)
-unlimited or fixed precision. There
-are also some non-standard modules that
+unlimited or fixed precision. There are also some non-standard modules that
provide faster implementations via external C libraries.
Here is a short, but incomplete summary:
X<=encoding> X<encoding>
This command is used for declaring the encoding of a document. Most
-users won't need this; but if your encoding isn't US-ASCII,
-then put a C<=encoding I<encodingname>> command very early in the document so
+users won't need this; but if your encoding isn't US-ASCII or Latin-1,
+then put a C<=encoding I<encodingname>> command early in the document so
that pod formatters will know how to decode the document. For
I<encodingname>, use a name recognized by the L<Encode::Supported>
-module. Some pod formatters may try to guess between a Latin-1 versus
-UTF-8 encoding, but they may guess wrong. It's best to be explicit if
-you use anything besides strict ASCII. Examples:
-
- =encoding latin1
+module. Examples:
=encoding utf8
And don't forget, all commands but C<=encoding> last up
until the end of its I<paragraph>, not its line. So in the
examples below, you can see that every command needs the blank
-line after it, to end its paragraph. (And some older Pod translators
-may require the C<=encoding> line to have a following blank line as
-well, even though it should be legal to omit.)
+line after it, to end its paragraph. (And some older
+Pod translators may require the C<=encoding> line to be similarly
+separated.)
Some examples of lists include:
=item *
-A naive but often sufficient heuristic for testing the first highbit
+A naive but sufficient heuristic for testing the first highbit
byte-sequence in a BOM-less file (whether in code or in Pod!), to see
whether that sequence is valid as UTF-8 (RFC 2279) is to check whether
-that the first byte in the sequence is in the range 0xC2 - 0xFD
+that the first byte in the sequence is in the range 0xC0 - 0xFD
I<and> whether the next byte is in the range
0x80 - 0xBF. If so, the parser may conclude that this file is in
UTF-8, and all highbit sequences in the file should be assumed to
be UTF-8. Otherwise the parser should treat the file as being
-in Latin-1. (A better check is to pass a copy of the sequence to
-L<utf8::decode()|utf8> which performs a full validity check on the
-sequence and returns TRUE if it is valid UTF-8, FALSE otherwise. This
-function is always pre-loaded, is fast because it is written in C, and
-will only get called at most once, so you don't need to avoid it out of
-performance concerns.)
-In the unlikely circumstance that the first highbit
+in Latin-1. In the unlikely circumstance that the first highbit
sequence in a truly non-UTF-8 file happens to appear to be UTF-8, one
can cater to our heuristic (as well as any more intelligent heuristic)
by prefacing that line with a comment line containing a highbit
-=encoding utf8
-
=head1 NAME
perlpolicy - Various and sundry policies and commitments related to the Perl core
=item *
-We "officially" support the two most recent stable release series. 5.16.x
-and earlier are now out of support. As of the release of 5.22.0, we will
-"officially" end support for Perl 5.18.x, other than providing security
+We "officially" support the two most recent stable release series. 5.12.x
+and earlier are now out of support. As of the release of 5.18.0, we will
+"officially" end support for Perl 5.14.x, other than providing security
updates as described below.
=item *
features, you should contact the perl5-porters mailinglist if you find
an experimental feature useful and want to help shape its future.
-Experimental features must be experimental in two stable releases before being
-marked non-experimental. Experimental features will only have their
-experimental status revoked when they no longer have any design-changing bugs
-open against them and when they have remained unchanged in behavior for the
-entire length of a development cycle. In other words, a feature present in
-v5.20.0 may be marked no longer experimental in v5.22.0 if and only if its
-behavior is unchanged throughout all of v5.21.
-
=item deprecated
If something in the Perl core is marked as B<deprecated>, we may remove it
=item *
Acceptable documentation updates are those that correct factual errors,
-explain significant bugs or deficiencies in the current implementation,
+explain significant bugs or deficiencies in the current implementation,
or fix broken markup.
=item *
=item *
-Patches that fix crashing bugs, assertion failures and
-memory corruption that do not otherwise change Perl's
-functionality or negatively impact performance are acceptable.
+Patches that fix crashing bugs that do not otherwise change Perl's
+functionality or negatively impact performance are acceptable.
=item *
=item *
-Updates to dual-life modules should consist of minimal patches to
+Updates to dual-life modules should consist of minimal patches to
fix crashing or security issues (as above).
=item *
-Minimal patches that fix platform-specific test failures or build or
+Minimal patches that fix platform-specific test failures or
installation issues are acceptable. When these changes are made
to dual-life modules for which CPAN is canonical, any changes
should be coordinated with the upstream author.
Any committer may cherry-pick any commit from blead to a maint branch if
they send mail to perl5-porters announcing their intent to cherry-pick
-a specific commit along with a rationale for doing so and at least two
+a specific commit along with a rationale for doing so and at least two
other committers respond to the list giving their assent. (This policy
applies to current and former pumpkings, as well as other committers.)
but, with very few exceptions, documentation isn't "dual-life" --
it doesn't need to fully describe how all old versions used to work.
-=head1 STANDARDS OF CONDUCT
-
-The official forum for the development of perl is the perl5-porters mailing
-list, mentioned above, and its bugtracker at rt.perl.org. All participants in
-discussion there are expected to adhere to a standard of conduct.
-
-=over 4
-
-=item *
-
-Always be civil.
-
-=item *
-
-Heed the moderators.
-
-=back
-
-Civility is simple: stick to the facts while avoiding demeaning remarks and
-sarcasm. It is not enough to be factual. You must also be civil. Responding
-in kind to incivility is not acceptable.
-
-While civility is required, kindness is encouraged; if you have any doubt about
-whether you are being civil, simply ask yourself, "Am I being kind?" and aspire
-to that.
-
-If the list moderators tell you that you are not being civil, carefully
-consider how your words have appeared before responding in any way. Were they
-kind? You may protest, but repeated protest in the face of a repeatedly
-reaffirmed decision is not acceptable.
-
-Unacceptable behavior will result in a public and clearly identified warning.
-Repeated unacceptable behavior will result in removal from the mailing list and
-revocation of rights to update rt.perl.org. The first removal is for one
-month. Subsequent removals will double in length. After six months with no
-warning, a user's ban length is reset. Removals, like warnings, are public.
-
-The list of moderators will be public knowledge. At present, it is:
-Aaron Crane, Andy Dougherty, Ricardo Signes, Steffen Müller.
=head1 CREDITS
platforms, may not be available in the same location, might accept
different arguments, can behave differently, and often present their
results in a platform-dependent way. Thus, you should seldom depend
-on them to produce consistent results. (Then again, if you're calling
+on them to produce consistent results. (Then again, if you're calling
I<netstat -a>, you probably don't expect it to run on both Unix and CP/M.)
One especially common bit of Perl code is opening a pipe to B<sendmail>:
- open(MAIL, '|/usr/lib/sendmail -t')
+ open(MAIL, '|/usr/lib/sendmail -t')
or die "cannot fork sendmail: $!";
This is fine for systems programming when sendmail is known to be
platforms; two, to provide users with information about whether
a given module works on a given platform.
-Also see:
+Also see:
=over 4
BSD/OS bsdos i386-bsdos
Darwin darwin darwin
DYNIX/ptx dynixptx i386-dynixptx
- FreeBSD freebsd freebsd-i386
+ FreeBSD freebsd freebsd-i386
Haiku haiku BePC-haiku
Linux linux arm-linux
Linux linux armv5tel-linux
OS $^O $Config{archname} ID Version
--------------------------------------------------------
- MS-DOS dos ?
- PC-DOS dos ?
+ MS-DOS dos ?
+ PC-DOS dos ?
OS/2 os2 ?
Windows 3.1 ? ? 0 3 01
Windows 95 MSWin32 MSWin32-x86 1 4 00
Windows 7 MSWin32 MSWin32-x64 2 6 01
Windows 2008 MSWin32 MSWin32-x86 2 6 01
Windows 2008 MSWin32 MSWin32-x64 2 6 01
- Windows CE MSWin32 ? 3
+ Windows CE MSWin32 ? 3
Cygwin cygwin cygwin
The various MSWin32 Perl's can distinguish the OS they are running on
-via the value of the fifth element of the list returned from
+via the value of the fifth element of the list returned from
Win32::GetOSVersion(). For example:
if ($^O eq 'MSWin32') {
=item *
Build instructions for Win32 in L<perlwin32>, or under the Cygnus environment
-in L<perlcygwin>.
+in L<perlcygwin>.
=item *
=item *
-The Cygwin environment for Win32; F<README.cygwin> (installed
+The Cygwin environment for Win32; F<README.cygwin> (installed
as L<perlcygwin>), L<http://www.cygwin.com/>
=item *
see if VMS is in a case sensitive mode.
What C<\n> represents depends on the type of file opened. It usually
-represents C<\012> but it could also be C<\015>, C<\012>, C<\015\012>,
-C<\000>, C<\040>, or nothing depending on the file organization and
-record format. The VMS::Stdio module provides access to the
+represents C<\012> but it could also be C<\015>, C<\012>, C<\015\012>,
+C<\000>, C<\040>, or nothing depending on the file organization and
+record format. The VMS::Stdio module provides access to the
special fopen() requirements of files with unusual attributes on VMS.
TCP/IP stacks are optional on VMS, so socket routines might not be
the BS200 POSIX-BC system (BS2000 is supported in perl 5.6 and greater).
See L<perlos390> for details. Note that for OS/400 there is also a port of
Perl 5.8.1/5.10.0 or later to the PASE which is ASCII-based (as opposed to
-ILE which is EBCDIC-based), see L<perlos400>.
+ILE which is EBCDIC-based), see L<perlos400>.
As of R2.5 of USS for OS/390 and Version 2.3 of VM/ESA these Unix
sub-systems do not support the C<#!> shebang trick for script invocation.
=head2 Acorn RISC OS
Because Acorns use ASCII with newlines (C<\n>) in text files as C<\012> like
-Unix, and because Unix filename emulation is turned on by default,
+Unix, and because Unix filename emulation is turned on by default,
most simple scripts will probably work "out of the box". The native
filesystem is modular, and individual filesystems are free to be
case-sensitive or insensitive, and are usually case-preserving. Some
directory without affecting its parent (and everyone else for that
matter).
-Because native operating system filehandles are global and are currently
+Because native operating system filehandles are global and are currently
allocated down from 255, with 0 being a reserved value, the Unix emulation
library emulates Unix filehandles. Consequently, you can't rely on
passing C<STDIN>, C<STDOUT>, or C<STDERR> to your children.
results for C<atan2()> may vary depending on any combination of the above.
Perl attempts to conform to the Open Group/IEEE standards for the results
returned from C<atan2()>, but cannot force the issue if the system Perl is
-run on does not allow it. (Tru64, HP-UX 10.20)
+run on does not allow it. (Tru64, HP-UX 10.20)
-The current version of the standards for C<atan2()> is available at
+The current version of the standards for C<atan2()> is available at
L<http://www.opengroup.org/onlinepubs/009695399/functions/atan2.html>.
=item binmode
=item exec
-C<exec LIST> without the use of indirect object syntax (C<exec PROGRAM LIST>)
-may fall back to trying the shell if the first spawn() fails. (Win32)
-
Does not automatically flush output handles on some platforms.
(SunOS, Solaris, HP-UX)
the C library _POSIX_EXIT macro so that it can be decoded by other
programs, particularly ones written in C, like the GNV package. (VMS)
-C<exit()> resets file pointers, which is a problem when called
-from a child process (created by C<fork()>) in C<BEGIN>.
+C<exit()> resets file pointers, which is a problem when called
+from a child process (created by C<fork()>) in C<BEGIN>.
A workaround is to use C<POSIX::_exit>. (Solaris)
exit unless $Config{archname} =~ /\bsolaris\b/;
I<scalar> will call the native command line direct and no such emulation
of a child Unix program will exists. Mileage B<will> vary. (S<RISC OS>)
-C<system LIST> without the use of indirect object syntax (C<system PROGRAM LIST>)
-may fall back to trying the shell if the first spawn() fails. (Win32)
-
Does not automatically flush output handles on some platforms.
(SunOS, Solaris, HP-UX)
The return value is POSIX-like (shifted up by 8 bits), which only allows
room for a made-up value derived from the severity bits of the native
-32-bit condition code (unless overridden by C<use vmsish 'status'>).
+32-bit condition code (unless overridden by C<use vmsish 'status'>).
If the native condition code is one that has a POSIX value encoded, the
POSIX value will be decoded to extract the expected exit value.
For more details see L<perlvms/$?>. (VMS)
=back
-=head1 EOL Platforms
+=head1 EOL Platforms
=head2 (Perl 5.20)
class, which is unaffected by C</x>), then you'll either have to
escape them (using backslashes or C<\Q...\E>) or encode them using octal,
hex, or C<\N{}> escapes.
-It is ineffective to try to continue a comment onto the next line by
-escaping the C<\n> with a backslash or C<\Q>.
You can use L</(?#text)> to create a comment that ends earlier than the
end of the current line, but C<text> also can't contain the closing
\o{}, \000 character whose ordinal is the given octal number
\l lowercase next char (think vi)
\u uppercase next char (think vi)
- \L lowercase until \E (think vi)
- \U uppercase until \E (think vi)
- \Q quote (disable) pattern metacharacters until \E
+ \L lowercase till \E (think vi)
+ \U uppercase till \E (think vi)
+ \Q quote (disable) pattern metacharacters till \E
\E end either case modification or quoted section, think vi
Details are in L<perlop/Quote and Quote-like Operators>.
matches a word that follows a tab, without including the tab in C<$&>.
Works only for fixed-width look-behind.
-There is a special form of this construct, called C<\K> (available since
-Perl 5.10.0), which causes the
+There is a special form of this construct, called C<\K>, which causes the
regex engine to "keep" everything it had matched prior to the C<\K> and
not include it in C<$&>. This effectively provides variable-length
look-behind. The use of C<\K> inside of another look-around assertion
/(?<NAME>(?&NAME_PAT))(?<ADDR>(?&ADDRESS_PAT))
(?(DEFINE)
(?<NAME_PAT>....)
- (?<ADDRESS_PAT>....)
+ (?<ADRESS_PAT>....)
)/x
Note that capture groups matched inside of recursion are not accessible
=item [6]
-C<\p{XPerlSpace}> and C<\p{Space}> match identically starting with Perl
+C<\p{SpacePerl}> and C<\p{Space}> match identically starting with Perl
v5.18. In earlier versions, these differ only in that in non-locale
-matching, C<\p{XPerlSpace}> does not match the vertical tab, C<\cK>.
+matching, C<\p{SpacePerl}> does not match the vertical tab, C<\cK>.
Same for the two ASCII-only range forms.
=back
X<\> X<backslash>
By using the backslash operator on a variable, subroutine, or value.
-(This works much like the & (address-of) operator in C.)
+(This works much like the & (address-of) operator in C.)
This typically creates I<another> reference to a variable, because
there's already a reference to the variable in the symbol table. But
the symbol table reference might go away, and you'll still have the
a list of references!
@list = (\$a, \@b, \%c);
- @list = \($a, @b, %c); # same thing!
+ @list = \($a, @b, %c); # same thing!
As a special case, C<\(@foo)> returns a list of references to the contents
of C<@foo>, not a reference to C<@foo> itself. Likewise for C<%foo>,
brackets:
$hashref = {
- 'Adam' => 'Eve',
- 'Clyde' => 'Bonnie',
+ 'Adam' => 'Eve',
+ 'Clyde' => 'Bonnie',
};
Anonymous hash and array composers like these can be intermixed freely to
closures work:
sub newprint {
- my $x = shift;
- return sub { my $y = shift; print "$x, $y!\n"; };
+ my $x = shift;
+ return sub { my $y = shift; print "$x, $y!\n"; };
}
$h = newprint("Howdy");
$g = newprint("Greetings");
value to a scalar instead of a typeglob as we do in the examples
below, there's no risk of that happening.
- splutter(*STDOUT); # pass the whole glob
- splutter(*STDOUT{IO}); # pass both file and dir handles
+ splutter(*STDOUT); # pass the whole glob
+ splutter(*STDOUT{IO}); # pass both file and dir handles
sub splutter {
- my $fh = shift;
- print $fh "her um well a hmmm\n";
+ my $fh = shift;
+ print $fh "her um well a hmmm\n";
}
- $rec = get_rec(*STDIN); # pass the whole glob
+ $rec = get_rec(*STDIN); # pass the whole glob
$rec = get_rec(*STDIN{IO}); # pass both file and dir handles
sub get_rec {
- my $fh = shift;
- return scalar <$fh>;
+ my $fh = shift;
+ return scalar <$fh>;
}
=back
the BLOCK can contain any arbitrary expression, in particular,
subscripted expressions:
- &{ $dispatch{$index} }(1,2,3); # call correct routine
+ &{ $dispatch{$index} }(1,2,3); # call correct routine
Because of being able to omit the curlies for the simple case of C<$$x>,
people often make the mistake of viewing the dereferencing symbols as
Consider the difference below; case 0 is a short-hand version of case 1,
I<not> case 2:
- $$hashref{"KEY"} = "VALUE"; # CASE 0
- ${$hashref}{"KEY"} = "VALUE"; # CASE 1
- ${$hashref{"KEY"}} = "VALUE"; # CASE 2
- ${$hashref->{"KEY"}} = "VALUE"; # CASE 3
+ $$hashref{"KEY"} = "VALUE"; # CASE 0
+ ${$hashref}{"KEY"} = "VALUE"; # CASE 1
+ ${$hashref{"KEY"}} = "VALUE"; # CASE 2
+ ${$hashref->{"KEY"}} = "VALUE"; # CASE 3
Case 2 is also deceptive in that you're accessing a variable
called %hashref, not dereferencing through $hashref to the hash
X<reference, numeric context>
if ($ref1 == $ref2) { # cheap numeric compare of references
- print "refs 1 and 2 refer to the same thing\n";
+ print "refs 1 and 2 refer to the same thing\n";
}
Using a reference as a string produces both its referent's type,
People frequently expect it to work like this. So it does.
$name = "foo";
- $$name = 1; # Sets $foo
- ${$name} = 2; # Sets $foo
- ${$name x 2} = 3; # Sets $foofoo
- $name->[0] = 4; # Sets $foo[0]
- @$name = (); # Clears @foo
- &$name(); # Calls &foo()
+ $$name = 1; # Sets $foo
+ ${$name} = 2; # Sets $foo
+ ${$name x 2} = 3; # Sets $foofoo
+ $name->[0] = 4; # Sets $foo[0]
+ @$name = (); # Clears @foo
+ &$name(); # Calls &foo()
$pack = "THAT";
- ${"${pack}::$name"} = 5; # Sets $THAT::foo without eval
+ ${"${pack}::$name"} = 5; # Sets $THAT::foo without eval
This is powerful, and slightly dangerous, in that it's possible
to intend (with the utmost sincerity) to use a hard reference, and
local $value = 10;
$ref = "value";
{
- my $value = 20;
- print $$ref;
+ my $value = 20;
+ print $$ref;
}
This will still print 10, not 20. Remember that local() affects package
using strict refs:
use strict 'refs';
- ${ bareword }; # Okay, means $bareword.
- ${ "bareword" }; # Error, symbolic reference.
+ ${ bareword }; # Okay, means $bareword.
+ ${ "bareword" }; # Error, symbolic reference.
Similarly, because of all the subscripting that is done using single words,
the same rule applies to any bareword that is used for subscripting a hash.
The red() and green() functions would be similar. To create these,
we'll assign a closure to a typeglob of the name of the function we're
-trying to build.
+trying to build.
@colors = qw(red blue green yellow orange purple violet);
for my $name (@colors) {
- no strict 'refs'; # allow symbol table manipulation
+ no strict 'refs'; # allow symbol table manipulation
*$name = *{uc $name} = sub { "<FONT COLOR='$name'>@_</FONT>" };
- }
+ }
Now all those different functions appear to exist independently. You can
call red(), RED(), blue(), BLUE(), green(), etc. This technique saves on
nested subroutines in other programming languages with their own private
variables, you'll have to work at it a bit in Perl. The intuitive coding
of this type of thing incurs mysterious warnings about "will not stay
-shared" due to the reasons explained above.
+shared" due to the reasons explained above.
For example, this won't work:
sub outer {
mode>, when it detects its program running with differing real and effective
user or group IDs. The setuid bit in Unix permissions is mode 04000, the
setgid bit mode 02000; either or both may be set. You can also enable taint
-mode explicitly by using the B<-T> command line flag. This flag is
+mode explicitly by using the B<-T> command line flag. This flag is
I<strongly> suggested for server programs and any program run on behalf of
-someone else, such as a CGI script. Once taint mode is on, it's on for
+someone else, such as a CGI script. Once taint mode is on, it's on for
the remainder of your script.
While in this mode, Perl takes special precautions called I<taint
When the taint mode (C<-T>) is in effect, the "." directory is removed
from C<@INC>, and the environment variables C<PERL5LIB> and C<PERLLIB>
-are ignored by Perl. You can still adjust C<@INC> from outside the
+are ignored by Perl. You can still adjust C<@INC> from outside the
program by using the C<-I> command line option as explained in
-L<perlrun>. The two environment variables are ignored because
+L<perlrun>. The two environment variables are ignored because
they are obscured, and a user running a program could be unaware that
they are set, whereas the C<-I> option is clearly visible and
therefore permitted.
perl -Mlib=/foo program
The benefit of using C<-Mlib=/foo> over C<-I/foo>, is that the former
-will automagically remove any duplicated directories, while the latter
+will automagically remove any duplicated directories, while the later
will not.
Note that if a tainted string is added to C<@INC>, the following
The PATH isn't the only environment variable which can cause problems.
Because some shells may use the variables IFS, CDPATH, ENV, and
BASH_ENV, Perl checks that those are either empty or untainted when
-starting subprocesses. You may wish to add something like this to your
+starting subprocesses. You may wish to add something like this to your
setid and taint-checking scripts.
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
care whether they use tainted values. Make judicious use of the file
tests in dealing with any user-supplied filenames. When possible, do
opens and such B<after> properly dropping any special user (or group!)
-privileges. Perl doesn't prevent you from
-opening tainted filenames for reading,
+privileges. Perl doesn't prevent you from opening tainted filenames for reading,
so be careful what you print out. The tainting mechanism is intended to
prevent stupid mistakes, not to remove the need for thought.
not be considered bullet-proof, though: it will not prevent the foreign
code to set up infinite loops, allocate gigabytes of memory, or even
abusing perl bugs to make the host interpreter crash or behave in
-unpredictable ways. In any case it's better avoided completely if you're
+unpredictable ways. In any case it's better avoided completely if you're
really concerned about security.
=head2 Security Bugs
Hash Algorithm - Hash algorithms like the one used in Perl are well
known to be vulnerable to collision attacks on their hash function.
Such attacks involve constructing a set of keys which collide into
-the same bucket producing inefficient behavior. Such attacks often
+the same bucket producing inefficient behavior. Such attacks often
depend on discovering the seed of the hash function used to map the
-keys to buckets. That seed is then used to brute-force a key set which
-can be used to mount a denial of service attack. In Perl 5.8.1 changes
+keys to buckets. That seed is then used to brute-force a key set which
+can be used to mount a denial of service attack. In Perl 5.8.1 changes
were introduced to harden Perl to such attacks, and then later in
Perl 5.18.0 these features were enhanced and additional protections
added.
At the time of this writing, Perl 5.18.0 is considered to be
well-hardened against algorithmic complexity attacks on its hash
-implementation. This is largely owed to the following measures
+implementation. This is largely owed to the following measures
mitigate attacks:
=over 4
=item Hash Seed Randomization
In order to make it impossible to know what seed to generate an attack
-key set for, this seed is randomly initialized at process start. This
+key set for, this seed is randomly initialized at process start. This
may be overridden by using the PERL_HASH_SEED environment variable, see
-L<perlrun/PERL_HASH_SEED>. This environment variable controls how
+L<perlrun/PERL_HASH_SEED>. This environment variable controls how
items are actually stored, not how they are presented via
C<keys>, C<values> and C<each>.
Modifying a hash by insertion will change the iteration order of that hash.
This behavior can be overridden by using C<hash_traversal_mask()> from
L<Hash::Util> or by using the PERL_PERTURB_KEYS environment variable,
-see L<perlrun/PERL_PERTURB_KEYS>. Note that this feature controls the
+see L<perlrun/PERL_PERTURB_KEYS>. Note that this feature controls the
"visible" order of the keys, and not the actual order they are stored in.
=item Bucket Order Perturbance
When items collide into a given hash bucket the order they are stored in
-the chain is no longer predictable in Perl 5.18. This
-has the intention to make it harder to observe a
-collision. This behavior can be overridden by using
+the chain is no longer predictable in Perl 5.18. This has the intention
+to make it harder to observe a collisions. This behavior can be overridden by using
the PERL_PERTURB_KEYS environment variable, see L<perlrun/PERL_PERTURB_KEYS>.
=item New Default Hash Function
The source code includes multiple hash algorithms to choose from. While we
believe that the default perl hash is robust to attack, we have included the
-hash function Siphash as a fall-back option. At the time of release of
+hash function Siphash as a fall-back option. At the time of release of
Perl 5.18.0 Siphash is believed to be of cryptographic strength. This is
not the default as it is much slower than the default hash.
=back
Without compiling a special Perl, there is no way to get the exact same
-behavior of any versions prior to Perl 5.18.0. The closest one can get
+behavior of any versions prior to Perl 5.18.0. The closest one can get
is by setting PERL_PERTURB_KEYS to 0 and setting the PERL_HASH_SEED
-to a known value. We do not advise those settings for production use
+to a known value. We do not advise those settings for production use
due to the above security considerations.
B<Perl has never guaranteed any ordering of the hash keys>, and
permutations (use e.g. the CPAN modules C<Algorithm::Permute> or
C<Algorithm::FastPermute>), or for any cryptographic applications.
-Tied hashes may have their own ordering and algorithmic complexity
-attacks.
-
=item *
Regular expressions - Perl's regular expression engine is so called NFA
one large indistinguishable list.
If no C<return> is found and if the last statement is an expression, its
-value is returned. If the last statement is a loop control structure
-like a C<foreach> or a C<while>, the returned value is unspecified. The
+value is returned. If the last statement is a loop control structure
+like a C<foreach> or a C<while>, the returned value is unspecified. The
empty sub returns the empty list.
X<subroutine, return value> X<return value> X<return>
all capitals is a loosely-held convention meaning it will be called
indirectly by the run-time system itself, usually due to a triggered event.
Subroutines whose name start with a left parenthesis are also reserved the
-same way. The following is a list of some subroutines that currently do
+same way. The following is a list of some subroutines that currently do
special, pre-defined things.
=over
X<state> X<state variable> X<static> X<variable, persistent> X<variable, static> X<closure>
There are two ways to build persistent private variables in Perl 5.10.
-First, you can simply use the C<state> feature. Or, you can use closures,
+First, you can simply use the C<state> feature. Or, you can use closures,
if you want to stay compatible with releases older than 5.10.
=head3 Persistent variables via state()
It's also worth taking a moment to explain what happens when you
C<local>ize a member of a composite type (i.e. an array or hash element).
-In this case, the element is C<local>ized I<by name>. This means that
+In this case, the element is C<local>ized I<by name>. This means that
when the scope of the C<local()> ends, the saved value will be
restored to the hash element whose key was named in the C<local()>, or
the array element whose index was named in the C<local()>. If that
You can use the C<delete local $array[$idx]> and C<delete local $hash{key}>
constructs to delete a composite type entry for the current block and restore
-it when it ends. They return the array/hash value before the localization,
+it when it ends. They return the array/hash value before the localization,
which means that they are respectively equivalent to
do {
$val
}
-except that for those the C<local> is
-scoped to the C<do> block. Slices are
+except that for those the C<local> is scoped to the C<do> block. Slices are
also accepted.
my %hash = (
The scalar/list context for the subroutine and for the right-hand
side of assignment is determined as if the subroutine call is replaced
-by a scalar. For example, consider:
+by a scalar. For example, consider:
data(2,3) = get_data(3,4);
all the subroutines are called in a list context.
Lvalue subroutines are convenient, but you have to keep in mind that,
-when used with objects, they may violate encapsulation. A normal
+when used with objects, they may violate encapsulation. A normal
mutator can check the supplied argument before setting the attribute
-it is protecting, an lvalue subroutine cannot. If you require any
+it is protecting, an lvalue subroutine cannot. If you require any
special processing when storing and retrieving the values, consider
using the CPAN module Sentinel or something similar.
baz(); # recursive call
}
-It is a known bug that lexical subroutines cannot be used as the C<SUBNAME>
-argument to C<sort>. This will be fixed in a future version of Perl.
-
=head3 C<state sub> vs C<my sub>
What is the difference between "state" subs and "my" subs? Each time that
that must start with that character (optionally preceded by C<my>,
C<our> or C<local>), with the exception of C<$>, which will
accept any scalar lvalue expression, such as C<$foo = 7> or
-C<< my_function()->[0] >>. The value passed as part of C<@_> will be a
+C<< my_function()->[0] >>. The value passed as part of C<@_> will be a
reference to the actual argument given in the subroutine call,
obtained by applying C<\> to that argument.
You can use the C<\[]> backslash group notation to specify more than one
-allowed argument type. For example:
+allowed argument type. For example:
sub myref (\[$@%&*])
As alluded to earlier you can also declare inlined subs dynamically at
BEGIN time if their body consists of a lexically-scoped scalar which
-has no other references. Only the first example here will be inlined:
+has no other references. Only the first example here will be inlined:
BEGIN {
my $var = 1;
};
If you redefine a subroutine that was eligible for inlining, you'll
-get a warning by default. You can use this warning to tell whether or
+get a warning by default. You can use this warning to tell whether or
not a particular subroutine is considered inlinable, since it's
different than the warning for overriding non-inlined subroutines:
C<glob>, the C<< <*> >> glob operator is overridden as well.
In a similar fashion, overriding the C<readline> function also overrides
-the equivalent I/O operator C<< <FILEHANDLE> >>. Also, overriding
+the equivalent I/O operator C<< <FILEHANDLE> >>. Also, overriding
C<readpipe> also overrides the operators C<``> and C<qx//>.
Finally, some built-ins (e.g. C<exists> or C<grep>) can't be overridden.
X<subroutine, declaration>
sub myname;
- $me = myname $0 or die "can't get myname";
+ $me = myname $0 or die "can't get myname";
A bare declaration like that declares the function to be a list operator,
not a unary operator, so you have to be careful to use parentheses (or
This is so that you can write loops like:
do {
- $line = <STDIN>;
- ...
+ $line = <STDIN>;
+ ...
} until !defined($line) || $line eq ".\n"
See L<perlfunc/do>. Note also that the loop control statements described
X<next> X<last> X<redo>
do {{
- next if $x == $y;
- # do something here
+ next if $x == $y;
+ # do something here
}} until $x++ > $z;
For C<last>, you have to be more elaborate:
X<last>
- LOOP: {
- do {
- last if $x = $y**2;
- # do something here
- } while $x++ <= $z;
+ LOOP: {
+ do {
+ last if $x = $y**2;
+ # do something here
+ } while $x++ <= $z;
}
B<NOTE:> The behaviour of a C<my>, C<state>, or
PHASE BLOCK
-The experimental C<given> statement is I<not automatically enabled>; see
+The experimental C<given> statement is I<not automatically enabled>; see
L</"Switch Statements"> below for how to do so, and the attendant caveats.
Unlike in C and Pascal, in Perl these are all defined in terms of BLOCKs,
die "Can't open $FOO: $!" unless open(FOO);
open(FOO) || die "Can't open $FOO: $!";
open(FOO) ? () : die "Can't open $FOO: $!";
- # a bit exotic, that last one
+ # a bit exotic, that last one
The C<if> statement is straightforward. Because BLOCKs are always
bounded by curly brackets, there is never any ambiguity about which
The C<next> command starts the next iteration of the loop:
LINE: while (<STDIN>) {
- next LINE if /^#/; # discard comments
- ...
+ next LINE if /^#/; # discard comments
+ ...
}
The C<last> command immediately exits the loop in question. The
C<continue> block, if any, is not executed:
LINE: while (<STDIN>) {
- last LINE if /^$/; # exit when done with header
- ...
+ last LINE if /^$/; # exit when done with header
+ ...
}
The C<redo> command restarts the loop block without evaluating the
want to skip ahead and get the next record.
while (<>) {
- chomp;
- if (s/\\$//) {
- $_ .= <>;
- redo unless eof();
- }
- # now process $_
+ chomp;
+ if (s/\\$//) {
+ $_ .= <>;
+ redo unless eof();
+ }
+ # now process $_
}
which is Perl shorthand for the more explicitly written version:
LINE: while (defined($line = <ARGV>)) {
- chomp($line);
- if ($line =~ s/\\$//) {
- redo LINE unless eof(); # not eof(ARGV)!
- }
- # now process $line
+ chomp($line);
+ if ($line =~ s/\\$//) {
+ $line .= <ARGV>;
+ redo LINE unless eof(); # not eof(ARGV)!
+ }
+ # now process $line
}
Note that if there were a C<continue> block on the above code, it would
# inspired by :1,$g/fred/s//WILMA/
while (<>) {
- m?(fred)? && s//WILMA $1 WILMA/;
- m?(barney)? && s//BETTY $1 BETTY/;
- m?(homer)? && s//MARGE $1 MARGE/;
+ m?(fred)? && s//WILMA $1 WILMA/;
+ m?(barney)? && s//BETTY $1 BETTY/;
+ m?(homer)? && s//MARGE $1 MARGE/;
} continue {
- print "$ARGV $.: $_";
- close ARGV if eof; # reset $.
- reset if eof; # reset ?pat?
+ print "$ARGV $.: $_";
+ close ARGV if eof; # reset $.
+ reset if eof; # reset ?pat?
}
If the word C<while> is replaced by the word C<until>, the sense of the
they aren't loops. You can double the braces to make them such, though.
if (/pattern/) {{
- last if /fred/;
- next if /barney/; # same effect as "last",
- # but doesn't document as well
- # do something here
+ last if /fred/;
+ next if /barney/; # same effect as "last",
+ # but doesn't document as well
+ # do something here
}}
This is caused by the fact that a block by itself acts as a loop that
that means that this:
for ($i = 1; $i < 10; $i++) {
- ...
+ ...
}
is the same as this:
$i = 1;
while ($i < 10) {
- ...
+ ...
} continue {
- $i++;
+ $i++;
}
There is one minor difference: if variables are declared with C<my>
and the control sections).
X<my>
-As a special case, if the test in the C<for> loop (or the corresponding
-C<while> loop) is empty, it is treated as true. That is, both
-
- for (;;) {
- ...
- }
-
-and
-
- while () {
- ...
- }
-
-are treated as infinite loops.
-
Besides the normal array index looping, C<for> can lend itself
to many other interesting applications. Here's one that avoids the
problem you get into if you explicitly test for end-of-file on
$on_a_tty = -t STDIN && -t STDOUT;
sub prompt { print "yes? " if $on_a_tty }
for ( prompt(); <STDIN>; prompt() ) {
- # do something
+ # do something
}
Using C<readline> (or the operator form, C<< <EXPR> >>) as the
for (@ary) { s/foo/bar/ }
for my $elem (@elements) {
- $elem *= 2;
+ $elem *= 2;
}
for $count (reverse(1..10), "BOOM") {
- print $count, "\n";
- sleep(1);
+ print $count, "\n";
+ sleep(1);
}
for (1..15) { print "Merry Christmas\n"; }
foreach $item (split(/:[\\\n:]*/, $ENV{TERMCAP})) {
- print "Item: $item\n";
+ print "Item: $item\n";
}
Here's how a C programmer might code up a particular algorithm in Perl:
for (my $i = 0; $i < @ary1; $i++) {
- for (my $j = 0; $j < @ary2; $j++) {
- if ($ary1[$i] > $ary2[$j]) {
- last; # can't go to outer :-(
- }
- $ary1[$i] += $ary2[$j];
- }
- # this is where that last takes me
+ for (my $j = 0; $j < @ary2; $j++) {
+ if ($ary1[$i] > $ary2[$j]) {
+ last; # can't go to outer :-(
+ }
+ $ary1[$i] += $ary2[$j];
+ }
+ # this is where that last takes me
}
Whereas here's how a Perl programmer more comfortable with the idiom might
OUTER: for my $wid (@ary1) {
INNER: for my $jet (@ary2) {
- next OUTER if $wid > $jet;
- $wid += $jet;
- }
- }
+ next OUTER if $wid > $jet;
+ $wid += $jet;
+ }
+ }
See how much easier this is? It's cleaner, safer, and faster. It's
cleaner because it's less noisy. It's safer because if code gets added
The BLOCK construct can be used to emulate case structures.
SWITCH: {
- if (/^abc/) { $abc = 1; last SWITCH; }
- if (/^def/) { $def = 1; last SWITCH; }
- if (/^xyz/) { $xyz = 1; last SWITCH; }
- $nothing = 1;
+ if (/^abc/) { $abc = 1; last SWITCH; }
+ if (/^def/) { $def = 1; last SWITCH; }
+ if (/^xyz/) { $xyz = 1; last SWITCH; }
+ $nothing = 1;
}
You'll also find that C<foreach> loop used to create a topicalizer
SWITCH:
for ($var) {
- if (/^abc/) { $abc = 1; last SWITCH; }
- if (/^def/) { $def = 1; last SWITCH; }
- if (/^xyz/) { $xyz = 1; last SWITCH; }
- $nothing = 1;
+ if (/^abc/) { $abc = 1; last SWITCH; }
+ if (/^def/) { $def = 1; last SWITCH; }
+ if (/^xyz/) { $xyz = 1; last SWITCH; }
+ $nothing = 1;
}
Such constructs are quite frequently used, both because older versions of
use v5.10.1;
for ($var) {
- when (/^abc/) { $abc = 1 }
- when (/^def/) { $def = 1 }
- when (/^xyz/) { $xyz = 1 }
- default { $nothing = 1 }
+ when (/^abc/) { $abc = 1 }
+ when (/^def/) { $def = 1 }
+ when (/^xyz/) { $xyz = 1 }
+ default { $nothing = 1 }
}
The C<foreach> is the non-experimental way to set a topicalizer.
use v5.10.1;
given ($var) {
- when (/^abc/) { $abc = 1 }
- when (/^def/) { $def = 1 }
- when (/^xyz/) { $xyz = 1 }
- default { $nothing = 1 }
+ when (/^abc/) { $abc = 1 }
+ when (/^def/) { $def = 1 }
+ when (/^xyz/) { $xyz = 1 }
+ default { $nothing = 1 }
}
As of 5.14, that can also be written this way:
use v5.14;
for ($var) {
- $abc = 1 when /^abc/;
- $def = 1 when /^def/;
- $xyz = 1 when /^xyz/;
- default { $nothing = 1 }
+ $abc = 1 when /^abc/;
+ $def = 1 when /^def/;
+ $xyz = 1 when /^xyz/;
+ default { $nothing = 1 }
}
Or if you don't care to play it safe, like this:
use v5.14;
given ($var) {
- $abc = 1 when /^abc/;
- $def = 1 when /^def/;
- $xyz = 1 when /^xyz/;
- default { $nothing = 1 }
+ $abc = 1 when /^abc/;
+ $def = 1 when /^def/;
+ $xyz = 1 when /^xyz/;
+ default { $nothing = 1 }
}
The arguments to C<given> and C<when> are in scalar context,
sub unimplemented { ... }
eval { unimplemented() };
if ($@ =~ /^Unimplemented at /) {
- say "I found an ellipsis!";
+ say "I found an ellipsis!";
}
You can only use the elliptical statement to stand in for a
...;
eval { ... };
sub somemeth {
- my $self = shift;
- ...;
+ my $self = shift;
+ ...;
}
$x = do {
- my $n;
- ...;
- say "Hurrah!";
- $n;
+ my $n;
+ ...;
+ say "Hurrah!";
+ $n;
};
The elliptical statement cannot stand in for an expression that
case, it doesn't think the C<...> is an ellipsis because it's expecting an
expression instead of a statement:
- @transformed = map { ... } @input; # syntax error
+ @transformed = map { ... } @input; # syntax error
+
+You can use a C<;> inside your block to denote that the C<{ ... }> is a
+block and not a hash reference constructor. Now the ellipsis works:
-Inside your block, you can use a C<;> before the ellipsis to denote that the
-C<{ ... }> is a block and not a hash reference constructor. Now the ellipsis
-works:
+ @transformed = map {; ... } @input; # ; disambiguates
- @transformed = map {; ... } @input; # ';' disambiguates
+ @transformed = map { ...; } @input; # ; disambiguates
Note: Some folks colloquially refer to this bit of punctuation as a
"yada-yada" or "triple-dot", but its true name
-is actually an ellipsis.
+is actually an ellipsis. Perl does not yet
+accept the Unicode version, U+2026 HORIZONTAL ELLIPSIS, as an alias for
+C<...>, but someday it may.
=head2 PODs: Embedded Documentation
X<POD> X<documentation>
=cut back to the compiler, nuff of this pod stuff!
sub snazzle($) {
- my $thingie = shift;
- .........
+ my $thingie = shift;
+ .........
}
Note that pod translators should look at only paragraphs beginning
use feature ":5.10";
given ($foo) {
- when (undef) {
- say '$foo is undefined';
- }
- when ("foo") {
- say '$foo is the string "foo"';
- }
- when ([1,3,5,7,9]) {
- say '$foo is an odd digit';
- continue; # Fall through
- }
- when ($_ < 100) {
- say '$foo is numerically less than 100';
- }
- when (\&complicated_check) {
- say 'a complicated check for $foo is true';
- }
- default {
- die q(I don't know what to do with $foo);
- }
+ when (undef) {
+ say '$foo is undefined';
+ }
+ when ("foo") {
+ say '$foo is the string "foo"';
+ }
+ when ([1,3,5,7,9]) {
+ say '$foo is an odd digit';
+ continue; # Fall through
+ }
+ when ($_ < 100) {
+ say '$foo is numerically less than 100';
+ }
+ when (\&complicated_check) {
+ say 'a complicated check for $foo is true';
+ }
+ default {
+ die q(I don't know what to do with $foo);
+ }
}
Before Perl 5.18, C<given(EXPR)> assigned the value of I<EXPR> to
merely a lexically scoped I<B<copy>> (!) of C<$_>, not a dynamically
scoped alias the way C<foreach> does. That made it similar to
- do { my $_ = EXPR; ... }
+ do { my $_ = EXPR; ... }
except that the block was automatically broken out of by a successful
C<when> or an explicit C<break>. Because it was only a copy, and because
case to the next:
given($foo) {
- when (/x/) { say '$foo contains an x'; continue }
- when (/y/) { say '$foo contains a y' }
- default { say '$foo does not contain a y' }
+ when (/x/) { say '$foo contains an x'; continue }
+ when (/y/) { say '$foo contains a y' }
+ default { say '$foo does not contain a y' }
}
=head3 Return value
evaluate to an empty list.
my $price = do {
- given ($item) {
- when (["pear", "apple"]) { 1 }
- break when "vote"; # My vote cannot be bought
- 1e10 when /Mona Lisa/;
- "unknown";
- }
+ given ($item) {
+ when (["pear", "apple"]) { 1 }
+ break when "vote"; # My vote cannot be bought
+ 1e10 when /Mona Lisa/;
+ "unknown";
+ }
};
Currently, C<given> blocks can't always
use v5.10.1;
my $count = 0;
for (@array) {
- when ("foo") { ++$count }
+ when ("foo") { ++$count }
}
print "\@array contains $count copies of 'foo'\n";
use v5.14;
my $count = 0;
for (@array) {
- ++$count when "foo";
+ ++$count when "foo";
}
print "\@array contains $count copies of 'foo'\n";
because Perl 5 would parse the expression
given $foo {
- ...
+ ...
}
as though the argument to C<given> were an element of the hash
sleep(15); # Let thread run for awhile
sub sub1 {
- my $count = 0;
+ $a = 0;
while (1) {
- $count++;
- print("\$count is $count\n");
+ $a++;
+ print("\$a is $a\n");
sleep(1);
}
}
use threads;
use threads::shared;
- my $x :shared = 1;
+ my $a :shared = 1;
my $thr1 = threads->create(\&sub1);
my $thr2 = threads->create(\&sub2);
$thr1->join();
$thr2->join();
- print("$x\n");
+ print("$a\n");
- sub sub1 { my $foo = $x; $x = $foo + 1; }
- sub sub2 { my $bar = $x; $x = $bar + 1; }
+ sub sub1 { my $foo = $a; $a = $foo + 1; }
+ sub sub2 { my $bar = $a; $a = $bar + 1; }
-What do you think C<$x> will be? The answer, unfortunately, is I<it
-depends>. Both C<sub1()> and C<sub2()> access the global variable C<$x>, once
+What do you think C<$a> will be? The answer, unfortunately, is I<it
+depends>. Both C<sub1()> and C<sub2()> access the global variable C<$a>, once
to read and once to write. Depending on factors ranging from your
thread implementation's scheduling algorithm to the phase of the moon,
-C<$x> can be 2 or 3.
+C<$a> can be 2 or 3.
Race conditions are caused by unsynchronized access to shared
data. Without explicit synchronization, there's no way to be sure that
possibility of error:
use threads;
- my $x :shared = 2;
- my $y :shared;
- my $z :shared;
- my $thr1 = threads->create(sub { $y = $x; $x = $y + 1; });
- my $thr2 = threads->create(sub { $z = $x; $x = $z + 1; });
+ my $a :shared = 2;
+ my $b :shared;
+ my $c :shared;
+ my $thr1 = threads->create(sub { $b = $a; $a = $b + 1; });
+ my $thr2 = threads->create(sub { $c = $a; $a = $c + 1; });
$thr1->join();
$thr2->join();
-Two threads both access C<$x>. Each thread can potentially be interrupted
-at any point, or be executed in any order. At the end, C<$x> could be 3
-or 4, and both C<$y> and C<$z> could be 2 or 3.
+Two threads both access C<$a>. Each thread can potentially be interrupted
+at any point, or be executed in any order. At the end, C<$a> could be 3
+or 4, and both C<$b> and C<$c> could be 2 or 3.
-Even C<$x += 5> or C<$x++> are not guaranteed to be atomic.
+Even C<$a += 5> or C<$a++> are not guaranteed to be atomic.
Whenever your program accesses data or resources that can be accessed
by other threads, you must take steps to coordinate access or risk
use threads;
- my $x :shared = 4;
- my $y :shared = 'foo';
+ my $a :shared = 4;
+ my $b :shared = 'foo';
my $thr1 = threads->create(sub {
- lock($x);
+ lock($a);
sleep(20);
- lock($y);
+ lock($b);
});
my $thr2 = threads->create(sub {
- lock($y);
+ lock($b);
sleep(20);
- lock($x);
+ lock($a);
});
This program will probably hang until you kill it. The only way it
first. A guaranteed-to-hang version is more complicated, but the
principle is the same.
-The first thread will grab a lock on C<$x>, then, after a pause during which
+The first thread will grab a lock on C<$a>, then, after a pause during which
the second thread has probably had time to do some work, try to grab a
-lock on C<$y>. Meanwhile, the second thread grabs a lock on C<$y>, then later
-tries to grab a lock on C<$x>. The second lock attempt for both threads will
+lock on C<$b>. Meanwhile, the second thread grabs a lock on C<$b>, then later
+tries to grab a lock on C<$a>. The second lock attempt for both threads will
block, each waiting for the other to release its lock.
This condition is called a deadlock, and it occurs whenever two or
There are a number of ways to handle this sort of problem. The best
way is to always have all threads acquire locks in the exact same
-order. If, for example, you lock variables C<$x>, C<$y>, and C<$z>, always lock
-C<$x> before C<$y>, and C<$y> before C<$z>. It's also best to hold on to locks for
+order. If, for example, you lock variables C<$a>, C<$b>, and C<$c>, always lock
+C<$a> before C<$b>, and C<$b> before C<$c>. It's also best to hold on to locks for
as short a period of time to minimize the risks of deadlock.
The other synchronization primitives described below can suffer from
Since kernel threading can interrupt a thread at any time, they will
uncover some of the implicit locking assumptions you may make in your
-program. For example, something as simple as C<$x = $x + 2> can behave
-unpredictably with kernel threads if C<$x> is visible to other
-threads, as another thread may have changed C<$x> between the time it
+program. For example, something as simple as C<$a = $a + 2> can behave
+unpredictably with kernel threads if C<$a> is visible to other
+threads, as another thread may have changed C<$a> between the time it
was fetched on the right hand side and the time the new value is
stored.
+++ /dev/null
-
-=encoding utf8
-
-=head1 NAME
-
-perlunicook - cookbookish examples of handling Unicode in Perl
-
-=head1 DESCRIPTION
-
-This manpage contains short recipes demonstrating how to handle common Unicode
-operations in Perl, plus one complete program at the end. Any undeclared
-variables in individual recipes are assumed to have a previous appropriate
-value in them.
-
-=head1 EXAMPLES
-
-=head2 ℞ 0: Standard preamble
-
-Unless otherwise notes, all examples below require this standard preamble
-to work correctly, with the C<#!> adjusted to work on your system:
-
- #!/usr/bin/env perl
-
- use utf8; # so literals and identifiers can be in UTF-8
- use v5.12; # or later to get "unicode_strings" feature
- use strict; # quote strings, declare variables
- use warnings; # on by default
- use warnings qw(FATAL utf8); # fatalize encoding glitches
- use open qw(:std :utf8); # undeclared streams in UTF-8
- use charnames qw(:full :short); # unneeded in v5.16
-
-This I<does> make even Unix programmers C<binmode> your binary streams,
-or open them with C<:raw>, but that's the only way to get at them
-portably anyway.
-
-B<WARNING>: C<use autodie> (pre 2.26) and C<use open> do not get along with each
-other.
-
-=head2 ℞ 1: Generic Unicode-savvy filter
-
-Always decompose on the way in, then recompose on the way out.
-
- use Unicode::Normalize;
-
- while (<>) {
- $_ = NFD($_); # decompose + reorder canonically
- ...
- } continue {
- print NFC($_); # recompose (where possible) + reorder canonically
- }
-
-=head2 ℞ 2: Fine-tuning Unicode warnings
-
-As of v5.14, Perl distinguishes three subclasses of UTF‑8 warnings.
-
- use v5.14; # subwarnings unavailable any earlier
- no warnings "nonchar"; # the 66 forbidden non-characters
- no warnings "surrogate"; # UTF-16/CESU-8 nonsense
- no warnings "non_unicode"; # for codepoints over 0x10_FFFF
-
-=head2 ℞ 3: Declare source in utf8 for identifiers and literals
-
-Without the all-critical C<use utf8> declaration, putting UTF‑8 in your
-literals and identifiers won’t work right. If you used the standard
-preamble just given above, this already happened. If you did, you can
-do things like this:
-
- use utf8;
-
- my $measure = "Ångström";
- my @μsoft = qw( cp852 cp1251 cp1252 );
- my @ὑπέρμεγας = qw( ὑπέρ μεγας );
- my @鯉 = qw( koi8-f koi8-u koi8-r );
- my $motto = "👪 💗 🐪"; # FAMILY, GROWING HEART, DROMEDARY CAMEL
-
-If you forget C<use utf8>, high bytes will be misunderstood as
-separate characters, and nothing will work right.
-
-=head2 ℞ 4: Characters and their numbers
-
-The C<ord> and C<chr> functions work transparently on all codepoints,
-not just on ASCII alone — nor in fact, not even just on Unicode alone.
-
- # ASCII characters
- ord("A")
- chr(65)
-
- # characters from the Basic Multilingual Plane
- ord("Σ")
- chr(0x3A3)
-
- # beyond the BMP
- ord("𝑛") # MATHEMATICAL ITALIC SMALL N
- chr(0x1D45B)
-
- # beyond Unicode! (up to MAXINT)
- ord("\x{20_0000}")
- chr(0x20_0000)
-
-=head2 ℞ 5: Unicode literals by character number
-
-In an interpolated literal, whether a double-quoted string or a
-regex, you may specify a character by its number using the
-C<\x{I<HHHHHH>}> escape.
-
- String: "\x{3a3}"
- Regex: /\x{3a3}/
-
- String: "\x{1d45b}"
- Regex: /\x{1d45b}/
-
- # even non-BMP ranges in regex work fine
- /[\x{1D434}-\x{1D467}]/
-
-=head2 ℞ 6: Get character name by number
-
- use charnames ();
- my $name = charnames::viacode(0x03A3);
-
-=head2 ℞ 7: Get character number by name
-
- use charnames ();
- my $number = charnames::vianame("GREEK CAPITAL LETTER SIGMA");
-
-=head2 ℞ 8: Unicode named characters
-
-Use the C<< \N{I<charname>} >> notation to get the character
-by that name for use in interpolated literals (double-quoted
-strings and regexes). In v5.16, there is an implicit
-
- use charnames qw(:full :short);
-
-But prior to v5.16, you must be explicit about which set of charnames you
-want. The C<:full> names are the official Unicode character name, alias, or
-sequence, which all share a namespace.
-
- use charnames qw(:full :short latin greek);
-
- "\N{MATHEMATICAL ITALIC SMALL N}" # :full
- "\N{GREEK CAPITAL LETTER SIGMA}" # :full
-
-Anything else is a Perl-specific convenience abbreviation. Specify one or
-more scripts by names if you want short names that are script-specific.
-
- "\N{Greek:Sigma}" # :short
- "\N{ae}" # latin
- "\N{epsilon}" # greek
-
-The v5.16 release also supports a C<:loose> import for loose matching of
-character names, which works just like loose matching of property names:
-that is, it disregards case, whitespace, and underscores:
-
- "\N{euro sign}" # :loose (from v5.16)
-
-=head2 ℞ 9: Unicode named sequences
-
-These look just like character names but return multiple codepoints.
-Notice the C<%vx> vector-print functionality in C<printf>.
-
- use charnames qw(:full);
- my $seq = "\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}";
- printf "U+%v04X\n", $seq;
- U+0100.0300
-
-=head2 ℞ 10: Custom named characters
-
-Use C<:alias> to give your own lexically scoped nicknames to existing
-characters, or even to give unnamed private-use characters useful names.
-
- use charnames ":full", ":alias" => {
- ecute => "LATIN SMALL LETTER E WITH ACUTE",
- "APPLE LOGO" => 0xF8FF, # private use character
- };
-
- "\N{ecute}"
- "\N{APPLE LOGO}"
-
-=head2 ℞ 11: Names of CJK codepoints
-
-Sinograms like “東京” come back with character names of
-C<CJK UNIFIED IDEOGRAPH-6771> and C<CJK UNIFIED IDEOGRAPH-4EAC>,
-because their “names” vary. The CPAN C<Unicode::Unihan> module
-has a large database for decoding these (and a whole lot more), provided you
-know how to understand its output.
-
- # cpan -i Unicode::Unihan
- use Unicode::Unihan;
- my $str = "東京";
- my $unhan = new Unicode::Unihan;
- for my $lang (qw(Mandarin Cantonese Korean JapaneseOn JapaneseKun)) {
- printf "CJK $str in %-12s is ", $lang;
- say $unhan->$lang($str);
- }
-
-prints:
-
- CJK 東京 in Mandarin is DONG1JING1
- CJK 東京 in Cantonese is dung1ging1
- CJK 東京 in Korean is TONGKYENG
- CJK 東京 in JapaneseOn is TOUKYOU KEI KIN
- CJK 東京 in JapaneseKun is HIGASHI AZUMAMIYAKO
-
-If you have a specific romanization scheme in mind,
-use the specific module:
-
- # cpan -i Lingua::JA::Romanize::Japanese
- use Lingua::JA::Romanize::Japanese;
- my $k2r = new Lingua::JA::Romanize::Japanese;
- my $str = "東京";
- say "Japanese for $str is ", $k2r->chars($str);
-
-prints
-
- Japanese for 東京 is toukyou
-
-=head2 ℞ 12: Explicit encode/decode
-
-On rare occasion, such as a database read, you may be
-given encoded text you need to decode.
-
- use Encode qw(encode decode);
-
- my $chars = decode("shiftjis", $bytes, 1);
- # OR
- my $bytes = encode("MIME-Header-ISO_2022_JP", $chars, 1);
-
-For streams all in the same encoding, don't use encode/decode; instead
-set the file encoding when you open the file or immediately after with
-C<binmode> as described later below.
-
-=head2 ℞ 13: Decode program arguments as utf8
-
- $ perl -CA ...
- or
- $ export PERL_UNICODE=A
- or
- use Encode qw(decode_utf8);
- @ARGV = map { decode_utf8($_, 1) } @ARGV;
-
-=head2 ℞ 14: Decode program arguments as locale encoding
-
- # cpan -i Encode::Locale
- use Encode qw(locale);
- use Encode::Locale;
-
- # use "locale" as an arg to encode/decode
- @ARGV = map { decode(locale => $_, 1) } @ARGV;
-
-=head2 ℞ 15: Declare STD{IN,OUT,ERR} to be utf8
-
-Use a command-line option, an environment variable, or else
-call C<binmode> explicitly:
-
- $ perl -CS ...
- or
- $ export PERL_UNICODE=S
- or
- use open qw(:std :utf8);
- or
- binmode(STDIN, ":utf8");
- binmode(STDOUT, ":utf8");
- binmode(STDERR, ":utf8");
-
-=head2 ℞ 16: Declare STD{IN,OUT,ERR} to be in locale encoding
-
- # cpan -i Encode::Locale
- use Encode;
- use Encode::Locale;
-
- # or as a stream for binmode or open
- binmode STDIN, ":encoding(console_in)" if -t STDIN;
- binmode STDOUT, ":encoding(console_out)" if -t STDOUT;
- binmode STDERR, ":encoding(console_out)" if -t STDERR;
-
-=head2 ℞ 17: Make file I/O default to utf8
-
-Files opened without an encoding argument will be in UTF-8:
-
- $ perl -CD ...
- or
- $ export PERL_UNICODE=D
- or
- use open qw(:utf8);
-
-=head2 ℞ 18: Make all I/O and args default to utf8
-
- $ perl -CSDA ...
- or
- $ export PERL_UNICODE=SDA
- or
- use open qw(:std :utf8);
- use Encode qw(decode_utf8);
- @ARGV = map { decode_utf8($_, 1) } @ARGV;
-
-=head2 ℞ 19: Open file with specific encoding
-
-Specify stream encoding. This is the normal way
-to deal with encoded text, not by calling low-level
-functions.
-
- # input file
- open(my $in_file, "< :encoding(UTF-16)", "wintext");
- OR
- open(my $in_file, "<", "wintext");
- binmode($in_file, ":encoding(UTF-16)");
- THEN
- my $line = <$in_file>;
-
- # output file
- open($out_file, "> :encoding(cp1252)", "wintext");
- OR
- open(my $out_file, ">", "wintext");
- binmode($out_file, ":encoding(cp1252)");
- THEN
- print $out_file "some text\n";
-
-More layers than just the encoding can be specified here. For example,
-the incantation C<":raw :encoding(UTF-16LE) :crlf"> includes implicit
-CRLF handling.
-
-=head2 ℞ 20: Unicode casing
-
-Unicode casing is very different from ASCII casing.
-
- uc("henry ⅷ") # "HENRY Ⅷ"
- uc("tschüß") # "TSCHÜSS" notice ß => SS
-
- # both are true:
- "tschüß" =~ /TSCHÜSS/i # notice ß => SS
- "Σίσυφος" =~ /ΣΊΣΥΦΟΣ/i # notice Σ,σ,ς sameness
-
-=head2 ℞ 21: Unicode case-insensitive comparisons
-
-Also available in the CPAN L<Unicode::CaseFold> module,
-the new C<fc> “foldcase” function from v5.16 grants
-access to the same Unicode casefolding as the C</i>
-pattern modifier has always used:
-
- use feature "fc"; # fc() function is from v5.16
-
- # sort case-insensitively
- my @sorted = sort { fc($a) cmp fc($b) } @list;
-
- # both are true:
- fc("tschüß") eq fc("TSCHÜSS")
- fc("Σίσυφος") eq fc("ΣΊΣΥΦΟΣ")
-
-=head2 ℞ 22: Match Unicode linebreak sequence in regex
-
-A Unicode linebreak matches the two-character CRLF
-grapheme or any of seven vertical whitespace characters.
-Good for dealing with textfiles coming from different
-operating systems.
-
- \R
-
- s/\R/\n/g; # normalize all linebreaks to \n
-
-=head2 ℞ 23: Get character category
-
-Find the general category of a numeric codepoint.
-
- use Unicode::UCD qw(charinfo);
- my $cat = charinfo(0x3A3)->{category}; # "Lu"
-
-=head2 ℞ 24: Disabling Unicode-awareness in builtin charclasses
-
-Disable C<\w>, C<\b>, C<\s>, C<\d>, and the POSIX
-classes from working correctly on Unicode either in this
-scope, or in just one regex.
-
- use v5.14;
- use re "/a";
-
- # OR
-
- my($num) = $str =~ /(\d+)/a;
-
-Or use specific un-Unicode properties, like C<\p{ahex}>
-and C<\p{POSIX_Digit>}. Properties still work normally
-no matter what charset modifiers (C</d /u /l /a /aa>)
-should be effect.
-
-=head2 ℞ 25: Match Unicode properties in regex with \p, \P
-
-These all match a single codepoint with the given
-property. Use C<\P> in place of C<\p> to match
-one codepoint lacking that property.
-
- \pL, \pN, \pS, \pP, \pM, \pZ, \pC
- \p{Sk}, \p{Ps}, \p{Lt}
- \p{alpha}, \p{upper}, \p{lower}
- \p{Latin}, \p{Greek}
- \p{script=Latin}, \p{script=Greek}
- \p{East_Asian_Width=Wide}, \p{EA=W}
- \p{Line_Break=Hyphen}, \p{LB=HY}
- \p{Numeric_Value=4}, \p{NV=4}
-
-=head2 ℞ 26: Custom character properties
-
-Define at compile-time your own custom character
-properties for use in regexes.
-
- # using private-use characters
- sub In_Tengwar { "E000\tE07F\n" }
-
- if (/\p{In_Tengwar}/) { ... }
-
- # blending existing properties
- sub Is_GraecoRoman_Title {<<'END_OF_SET'}
- +utf8::IsLatin
- +utf8::IsGreek
- &utf8::IsTitle
- END_OF_SET
-
- if (/\p{Is_GraecoRoman_Title}/ { ... }
-
-=head2 ℞ 27: Unicode normalization
-
-Typically render into NFD on input and NFC on output. Using NFKC or NFKD
-functions improves recall on searches, assuming you've already done to the
-same text to be searched. Note that this is about much more than just pre-
-combined compatibility glyphs; it also reorders marks according to their
-canonical combining classes and weeds out singletons.
-
- use Unicode::Normalize;
- my $nfd = NFD($orig);
- my $nfc = NFC($orig);
- my $nfkd = NFKD($orig);
- my $nfkc = NFKC($orig);
-
-=head2 ℞ 28: Convert non-ASCII Unicode numerics
-
-Unless you’ve used C</a> or C</aa>, C<\d> matches more than
-ASCII digits only, but Perl’s implicit string-to-number
-conversion does not current recognize these. Here’s how to
-convert such strings manually.
-
- use v5.14; # needed for num() function
- use Unicode::UCD qw(num);
- my $str = "got Ⅻ and ४५६७ and ⅞ and here";
- my @nums = ();
- while ($str =~ /(\d+|\N)/g) { # not just ASCII!
- push @nums, num($1);
- }
- say "@nums"; # 12 4567 0.875
-
- use charnames qw(:full);
- my $nv = num("\N{RUMI DIGIT ONE}\N{RUMI DIGIT TWO}");
-
-=head2 ℞ 29: Match Unicode grapheme cluster in regex
-
-Programmer-visible “characters” are codepoints matched by C</./s>,
-but user-visible “characters” are graphemes matched by C</\X/>.
-
- # Find vowel *plus* any combining diacritics,underlining,etc.
- my $nfd = NFD($orig);
- $nfd =~ / (?=[aeiou]) \X /xi
-
-=head2 ℞ 30: Extract by grapheme instead of by codepoint (regex)
-
- # match and grab five first graphemes
- my($first_five) = $str =~ /^ ( \X{5} ) /x;
-
-=head2 ℞ 31: Extract by grapheme instead of by codepoint (substr)
-
- # cpan -i Unicode::GCString
- use Unicode::GCString;
- my $gcs = Unicode::GCString->new($str);
- my $first_five = $gcs->substr(0, 5);
-
-=head2 ℞ 32: Reverse string by grapheme
-
-Reversing by codepoint messes up diacritics, mistakenly converting
-C<crème brûlée> into C<éel̂urb em̀erc> instead of into C<eélûrb emèrc>;
-so reverse by grapheme instead. Both these approaches work
-right no matter what normalization the string is in:
-
- $str = join("", reverse $str =~ /\X/g);
-
- # OR: cpan -i Unicode::GCString
- use Unicode::GCString;
- $str = reverse Unicode::GCString->new($str);
-
-=head2 ℞ 33: String length in graphemes
-
-The string C<brûlée> has six graphemes but up to eight codepoints.
-This counts by grapheme, not by codepoint:
-
- my $str = "brûlée";
- my $count = 0;
- while ($str =~ /\X/g) { $count++ }
-
- # OR: cpan -i Unicode::GCString
- use Unicode::GCString;
- my $gcs = Unicode::GCString->new($str);
- my $count = $gcs->length;
-
-=head2 ℞ 34: Unicode column-width for printing
-
-Perl’s C<printf>, C<sprintf>, and C<format> think all
-codepoints take up 1 print column, but many take 0 or 2.
-Here to show that normalization makes no difference,
-we print out both forms:
-
- use Unicode::GCString;
- use Unicode::Normalize;
-
- my @words = qw/crème brûlée/;
- @words = map { NFC($_), NFD($_) } @words;
-
- for my $str (@words) {
- my $gcs = Unicode::GCString->new($str);
- my $cols = $gcs->columns;
- my $pad = " " x (10 - $cols);
- say str, $pad, " |";
- }
-
-generates this to show that it pads correctly no matter
-the normalization:
-
- crème |
- crème |
- brûlée |
- brûlée |
-
-=head2 ℞ 35: Unicode collation
-
-Text sorted by numeric codepoint follows no reasonable alphabetic order;
-use the UCA for sorting text.
-
- use Unicode::Collate;
- my $col = Unicode::Collate->new();
- my @list = $col->sort(@old_list);
-
-See the I<ucsort> program from the L<Unicode::Tussle> CPAN module
-for a convenient command-line interface to this module.
-
-=head2 ℞ 36: Case- I<and> accent-insensitive Unicode sort
-
-Specify a collation strength of level 1 to ignore case and
-diacritics, only looking at the basic character.
-
- use Unicode::Collate;
- my $col = Unicode::Collate->new(level => 1);
- my @list = $col->sort(@old_list);
-
-=head2 ℞ 37: Unicode locale collation
-
-Some locales have special sorting rules.
-
- # either use v5.12, OR: cpan -i Unicode::Collate::Locale
- use Unicode::Collate::Locale;
- my $col = Unicode::Collate::Locale->new(locale => "de__phonebook");
- my @list = $col->sort(@old_list);
-
-The I<ucsort> program mentioned above accepts a C<--locale> parameter.
-
-=head2 ℞ 38: Making C<cmp> work on text instead of codepoints
-
-Instead of this:
-
- @srecs = sort {
- $b->{AGE} <=> $a->{AGE}
- ||
- $a->{NAME} cmp $b->{NAME}
- } @recs;
-
-Use this:
-
- my $coll = Unicode::Collate->new();
- for my $rec (@recs) {
- $rec->{NAME_key} = $coll->getSortKey( $rec->{NAME} );
- }
- @srecs = sort {
- $b->{AGE} <=> $a->{AGE}
- ||
- $a->{NAME_key} cmp $b->{NAME_key}
- } @recs;
-
-=head2 ℞ 39: Case- I<and> accent-insensitive comparisons
-
-Use a collator object to compare Unicode text by character
-instead of by codepoint.
-
- use Unicode::Collate;
- my $es = Unicode::Collate->new(
- level => 1,
- normalization => undef
- );
-
- # now both are true:
- $es->eq("García", "GARCIA" );
- $es->eq("Márquez", "MARQUEZ");
-
-=head2 ℞ 40: Case- I<and> accent-insensitive locale comparisons
-
-Same, but in a specific locale.
-
- my $de = Unicode::Collate::Locale->new(
- locale => "de__phonebook",
- );
-
- # now this is true:
- $de->eq("tschüß", "TSCHUESS"); # notice ü => UE, ß => SS
-
-=head2 ℞ 41: Unicode linebreaking
-
-Break up text into lines according to Unicode rules.
-
- # cpan -i Unicode::LineBreak
- use Unicode::LineBreak;
- use charnames qw(:full);
-
- my $para = "This is a super\N{HYPHEN}long string. " x 20;
- my $fmt = new Unicode::LineBreak;
- print $fmt->break($para), "\n";
-
-=head2 ℞ 42: Unicode text in DBM hashes, the tedious way
-
-Using a regular Perl string as a key or value for a DBM
-hash will trigger a wide character exception if any codepoints
-won’t fit into a byte. Here’s how to manually manage the translation:
-
- use DB_File;
- use Encode qw(encode decode);
- tie %dbhash, "DB_File", "pathname";
-
- # STORE
-
- # assume $uni_key and $uni_value are abstract Unicode strings
- my $enc_key = encode("UTF-8", $uni_key, 1);
- my $enc_value = encode("UTF-8", $uni_value, 1);
- $dbhash{$enc_key} = $enc_value;
-
- # FETCH
-
- # assume $uni_key holds a normal Perl string (abstract Unicode)
- my $enc_key = encode("UTF-8", $uni_key, 1);
- my $enc_value = $dbhash{$enc_key};
- my $uni_value = decode("UTF-8", $enc_value, 1);
-
-=head2 ℞ 43: Unicode text in DBM hashes, the easy way
-
-Here’s how to implicitly manage the translation; all encoding
-and decoding is done automatically, just as with streams that
-have a particular encoding attached to them:
-
- use DB_File;
- use DBM_Filter;
-
- my $dbobj = tie %dbhash, "DB_File", "pathname";
- $dbobj->Filter_Value("utf8"); # this is the magic bit
-
- # STORE
-
- # assume $uni_key and $uni_value are abstract Unicode strings
- $dbhash{$uni_key} = $uni_value;
-
- # FETCH
-
- # $uni_key holds a normal Perl string (abstract Unicode)
- my $uni_value = $dbhash{$uni_key};
-
-=head2 ℞ 44: PROGRAM: Demo of Unicode collation and printing
-
-Here’s a full program showing how to make use of locale-sensitive
-sorting, Unicode casing, and managing print widths when some of the
-characters take up zero or two columns, not just one column each time.
-When run, the following program produces this nicely aligned output:
-
- Crème Brûlée....... €2.00
- Éclair............. €1.60
- Fideuà............. €4.20
- Hamburger.......... €6.00
- Jamón Serrano...... €4.45
- Linguiça........... €7.00
- Pâté............... €4.15
- Pears.............. €2.00
- Pêches............. €2.25
- Smørbrød........... €5.75
- Spätzle............ €5.50
- Xoriço............. €3.00
- Γύρος.............. €6.50
- 막걸리............. €4.00
- おもち............. €2.65
- お好み焼き......... €8.00
- シュークリーム..... €1.85
- 寿司............... €9.99
- 包子............... €7.50
-
-Here's that program; tested on v5.14.
-
- #!/usr/bin/env perl
- # umenu - demo sorting and printing of Unicode food
- #
- # (obligatory and increasingly long preamble)
- #
- use utf8;
- use v5.14; # for locale sorting
- use strict;
- use warnings;
- use warnings qw(FATAL utf8); # fatalize encoding faults
- use open qw(:std :utf8); # undeclared streams in UTF-8
- use charnames qw(:full :short); # unneeded in v5.16
-
- # std modules
- use Unicode::Normalize; # std perl distro as of v5.8
- use List::Util qw(max); # std perl distro as of v5.10
- use Unicode::Collate::Locale; # std perl distro as of v5.14
-
- # cpan modules
- use Unicode::GCString; # from CPAN
-
- # forward defs
- sub pad($$$);
- sub colwidth(_);
- sub entitle(_);
-
- my %price = (
- "γύρος" => 6.50, # gyros
- "pears" => 2.00, # like um, pears
- "linguiça" => 7.00, # spicy sausage, Portuguese
- "xoriço" => 3.00, # chorizo sausage, Catalan
- "hamburger" => 6.00, # burgermeister meisterburger
- "éclair" => 1.60, # dessert, French
- "smørbrød" => 5.75, # sandwiches, Norwegian
- "spätzle" => 5.50, # Bayerisch noodles, little sparrows
- "包子" => 7.50, # bao1 zi5, steamed pork buns, Mandarin
- "jamón serrano" => 4.45, # country ham, Spanish
- "pêches" => 2.25, # peaches, French
- "シュークリーム" => 1.85, # cream-filled pastry like eclair
- "막걸리" => 4.00, # makgeolli, Korean rice wine
- "寿司" => 9.99, # sushi, Japanese
- "おもち" => 2.65, # omochi, rice cakes, Japanese
- "crème brûlée" => 2.00, # crema catalana
- "fideuà" => 4.20, # more noodles, Valencian
- # (Catalan=fideuada)
- "pâté" => 4.15, # gooseliver paste, French
- "お好み焼き" => 8.00, # okonomiyaki, Japanese
- );
-
- my $width = 5 + max map { colwidth } keys %price;
-
- # So the Asian stuff comes out in an order that someone
- # who reads those scripts won't freak out over; the
- # CJK stuff will be in JIS X 0208 order that way.
- my $coll = new Unicode::Collate::Locale locale => "ja";
-
- for my $item ($coll->sort(keys %price)) {
- print pad(entitle($item), $width, ".");
- printf " €%.2f\n", $price{$item};
- }
-
- sub pad($$$) {
- my($str, $width, $padchar) = @_;
- return $str . ($padchar x ($width - colwidth($str)));
- }
-
- sub colwidth(_) {
- my($str) = @_;
- return Unicode::GCString->new($str)->columns;
- }
-
- sub entitle(_) {
- my($str) = @_;
- $str =~ s{ (?=\pL)(\S) (\S*) }
- { ucfirst($1) . lc($2) }xge;
- return $str;
- }
-
-=head1 SEE ALSO
-
-See these manpages, some of which are CPAN modules:
-L<perlunicode>, L<perluniprops>,
-L<perlre>, L<perlrecharclass>,
-L<perluniintro>, L<perlunitut>, L<perlunifaq>,
-L<PerlIO>, L<DB_File>, L<DBM_Filter>, L<DBM_Filter::utf8>,
-L<Encode>, L<Encode::Locale>,
-L<Unicode::UCD>,
-L<Unicode::Normalize>,
-L<Unicode::GCString>, L<Unicode::LineBreak>,
-L<Unicode::Collate>, L<Unicode::Collate::Locale>,
-L<Unicode::Unihan>,
-L<Unicode::CaseFold>,
-L<Unicode::Tussle>,
-L<Lingua::JA::Romanize::Japanese>,
-L<Lingua::ZH::Romanize::Pinyin>,
-L<Lingua::KO::Romanize::Hangul>.
-
-The L<Unicode::Tussle> CPAN module includes many programs
-to help with working with Unicode, including
-these programs to fully or partly replace standard utilities:
-I<tcgrep> instead of I<egrep>,
-I<uniquote> instead of I<cat -v> or I<hexdump>,
-I<uniwc> instead of I<wc>,
-I<unilook> instead of I<look>,
-I<unifmt> instead of I<fmt>,
-and
-I<ucsort> instead of I<sort>.
-For exploring Unicode character names and character properties,
-see its I<uniprops>, I<unichars>, and I<uninames> programs.
-It also supplies these programs, all of which are general filters that do Unicode-y things:
-I<unititle> and I<unicaps>;
-I<uniwide> and I<uninarrow>;
-I<unisupers> and I<unisubs>;
-I<nfd>, I<nfc>, I<nfkd>, and I<nfkc>;
-and I<uc>, I<lc>, and I<tc>.
-
-Finally, see the published Unicode Standard (page numbers are from version
-6.0.0), including these specific annexes and technical reports:
-
-=over
-
-=item §3.13 Default Case Algorithms, page 113;
-§4.2 Case, pages 120–122;
-Case Mappings, page 166–172, especially Caseless Matching starting on page 170.
-
-=item UAX #44: Unicode Character Database
-
-=item UTS #18: Unicode Regular Expressions
-
-=item UAX #15: Unicode Normalization Forms
-
-=item UTS #10: Unicode Collation Algorithm
-
-=item UAX #29: Unicode Text Segmentation
-
-=item UAX #14: Unicode Line Breaking Algorithm
-
-=item UAX #11: East Asian Width
-
-=back
-
-=head1 AUTHOR
-
-Tom Christiansen E<lt>tchrist@perl.comE<gt> wrote this, with occasional
-kibbitzing from Larry Wall and Jeffrey Friedl in the background.
-
-=head1 COPYRIGHT AND LICENCE
-
-Copyright © 2012 Tom Christiansen.
-
-This program is free software; you may redistribute it and/or modify it
-under the same terms as Perl itself.
-
-Most of these examples taken from the current edition of the “Camel Book”;
-that is, from the 4ᵗʰ Edition of I<Programming Perl>, Copyright © 2012 Tom
-Christiansen <et al.>, 2012-02-13 by O’Reilly Media. The code itself is
-freely redistributable, and you are encouraged to transplant, fold,
-spindle, and mutilate any of the examples in this manpage however you please
-for inclusion into your own programs without any encumbrance whatsoever.
-Acknowledgement via code comment is polite but not required.
-
-=head1 REVISION HISTORY
-
-v1.0.0 – first public release, 2012-02-27
-
displayed as C<\x..>, and the rest of the characters as themselves:
sub nice_string {
- join("",
- map { $_ > 255 # if wide character...
- ? sprintf("\\x{%04X}", $_) # \x{...}
- : chr($_) =~ /[[:cntrl:]]/ # else if control character...
- ? sprintf("\\x%02X", $_) # \x..
- : quotemeta(chr($_)) # else quoted or as themselves
- } unpack("W*", $_[0])); # unpack Unicode characters
+ join("",
+ map { $_ > 255 ? # if wide character...
+ sprintf("\\x{%04X}", $_) : # \x{...}
+ chr($_) =~ /[[:cntrl:]]/ ? # else if control character...
+ sprintf("\\x%02X", $_) : # \x..
+ quotemeta(chr($_)) # else quoted or as themselves
+ } unpack("W*", $_[0])); # unpack Unicode characters
}
For example,
=over 3
-=item L<config_data|config_data>
-
-Query or change configuration of Perl modules that use Module::Build-based
-configuration files for features and config data.
-
=item L<libnetcfg|libnetcfg>
To display and change the libnet configuration run the libnetcfg command.
C<'> is taken to be a I<package qualifier>; see L<perlmod>.
Perl variable names may also be a sequence of digits or a single
-punctuation or control character (with the literal control character
-form deprecated). These names are all reserved for
+punctuation or control character. These names are all reserved for
special uses by Perl; for example, the all-digits names are used
to hold data captured by backreferences after a regular expression
match. Perl has a special syntax for the single-control-character
The subscript separator for multidimensional array emulation. If you
refer to a hash element as
- $foo{$x,$y,$z}
+ $foo{$a,$b,$c}
it really means
- $foo{join($;, $x, $y, $z)}
+ $foo{join($;, $a, $b, $c)}
But don't put
- @foo{$x,$y,$z} # a slice--note the @
+ @foo{$a,$b,$c} # a slice--note the @
which means
- ($foo{$x},$foo{$y},$foo{$z})
+ ($foo{$a},$foo{$b},$foo{$c})
Default is "\034", the same as SUBSEP in B<awk>. If your keys contain
binary data there might not be any safe value for C<$;>.
(The same is done if an existing logical name was defined in
executive or kernel mode; an existing user or supervisor mode
logical name is reset to the new value.) If the value is an empty
-string, the logical name's translation is defined as a single C<NUL>
-(ASCII C<\0>) character, since a logical name cannot translate to a
+string, the logical name's translation is defined as a single NUL
+(ASCII 00) character, since a logical name cannot translate to a
zero-length string. (This restriction does not apply to CLI symbols
or CRTL C<environ> values; they are set to the empty string.)
An element of the CRTL C<environ> array can be set only if your
if (!(mg = mg_find_mglob(sv))) {
mg = sv_magicext_mglob(sv);
}
- assert(SvPOK(sv));
- MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
+ assert(SvPOK(dstr));
+ MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig);
}
if (old != rx)
(void)ReREFCNT_inc(rx);
break;
}
itembytes = s - item;
- chophere = s;
break;
}
goto append;
case FF_CHOP: /* (for ^*) chop the current item */
- if (sv != &PL_sv_no) {
+ {
const char *s = chophere;
if (chopspace) {
while (isSPACE(*s))
const char *const send = s + len;
item_is_utf8 = DO_UTF8(sv);
- chophere = s + len;
if (!len)
break;
trans = 0;
gotsome = TRUE;
+ chophere = s + len;
source = (U8 *) s;
to_copy = len;
while (s < send) {
}
}
if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
+ int rc = 0;
/* Will be used to set PL_tainting below */
Uid_t tmp_uid = PerlProc_getuid();
Uid_t tmp_euid = PerlProc_geteuid();
Gid_t tmp_gid = PerlProc_getgid();
Gid_t tmp_egid = PerlProc_getegid();
- /* XXX $> et al currently silently ignore failures */
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- PERL_UNUSED_RESULT(
- setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
- (Uid_t)-1));
+ rc = setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
+ (Uid_t)-1);
#else
# ifdef HAS_SETREUID
- PERL_UNUSED_RESULT(
- setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
+ rc = setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
# else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
- PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
+ rc = setruid(PL_delaymagic_uid);
PL_delaymagic &= ~DM_RUID;
}
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
- PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
+ rc = seteuid(PL_delaymagic_euid);
PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
if (PL_delaymagic & DM_UID) {
if (PL_delaymagic_uid != PL_delaymagic_euid)
DIE(aTHX_ "No setreuid available");
- PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
+ rc = PerlProc_setuid(PL_delaymagic_uid);
}
# endif /* HAS_SETREUID */
#endif /* HAS_SETRESUID */
+ /* XXX $> et al currently silently ignore failures */
+ PERL_UNUSED_VAR(rc);
+
tmp_uid = PerlProc_getuid();
tmp_euid = PerlProc_geteuid();
}
- /* XXX $> et al currently silently ignore failures */
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- PERL_UNUSED_RESULT(
- setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
- (Gid_t)-1));
+ rc = setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
+ (Gid_t)-1);
#else
# ifdef HAS_SETREGID
- PERL_UNUSED_RESULT(
- setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
+ rc = setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
# else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
- PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
+ rc = setrgid(PL_delaymagic_gid);
PL_delaymagic &= ~DM_RGID;
}
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
- PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
+ rc = setegid(PL_delaymagic_egid);
PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
if (PL_delaymagic & DM_GID) {
if (PL_delaymagic_gid != PL_delaymagic_egid)
DIE(aTHX_ "No setregid available");
- PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
+ rc = PerlProc_setgid(PL_delaymagic_gid);
}
# endif /* HAS_SETREGID */
#endif /* HAS_SETRESGID */
+ /* XXX $> et al currently silently ignore failures */
+ PERL_UNUSED_VAR(rc);
+
tmp_gid = PerlProc_getgid();
tmp_egid = PerlProc_getegid();
}
len = SvCUR(sv);
if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
goto nuts2;
-#if defined(_AIX)
- /* XXX Configure test: does getsockopt set the length properly? */
- if (len == 256)
- len = sizeof(int);
-#endif
SvCUR_set(sv, len);
*SvEND(sv) ='\0';
PUSHs(sv);
Pid_t pgrp;
Pid_t pid;
pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
- if (MAXARG > 0) pid = TOPs ? TOPi : 0;
+ if (MAXARG > 0) pid = TOPs && TOPi;
else {
pid = 0;
XPUSHi(-1);
}
else {
NV input = Perl_floor(POPn);
- const bool pl_isnan = Perl_isnan(input);
when = (Time64_T)input;
- if (UNLIKELY(pl_isnan || when != input)) {
+ if (when != input) {
/* diag_listed_as: gmtime(%f) too large */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too large", opname, input);
- if (pl_isnan) {
- err = NULL;
- goto failed;
- }
}
}
}
if (err == NULL) {
- /* diag_listed_as: gmtime(%f) failed */
/* XXX %lld broken for quads */
- failed:
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") failed", opname, when);
}
if (GIMME != G_ARRAY) { /* scalar context */
+ SV *tsv;
+ /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
+ double year = (double)tmbuf.tm_year + 1900;
+
EXTEND(SP, 1);
EXTEND_MORTAL(1);
if (err == NULL)
RETPUSHUNDEF;
- else {
- mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
- dayname[tmbuf.tm_wday],
- monname[tmbuf.tm_mon],
- tmbuf.tm_mday,
- tmbuf.tm_hour,
- tmbuf.tm_min,
- tmbuf.tm_sec,
- /* XXX newSVpvf()'s %lld type is broken,
- * so cheat with a double */
- (double)tmbuf.tm_year + 1900));
- }
+
+ tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
+ dayname[tmbuf.tm_wday],
+ monname[tmbuf.tm_mon],
+ tmbuf.tm_mday,
+ tmbuf.tm_hour,
+ tmbuf.tm_min,
+ tmbuf.tm_sec,
+ year);
+ mPUSHs(tsv);
}
else { /* list context */
if ( err == NULL )
#define PERL_ARGS_ASSERT_SV_NV \
assert(sv)
-PERL_STATIC_INLINE bool S_sv_only_taint_gmagic(SV *sv)
- __attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC \
- assert(sv)
-
PERL_CALLCONV char* Perl_sv_peek(pTHX_ SV* sv);
PERL_CALLCONV void Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_SWASH_INIT \
assert(pkg); assert(name); assert(listsv)
-/* PERL_CALLCONV void sync_locale(void); */
PERL_CALLCONV void Perl_sys_init(int* argc, char*** argv)
__attribute__nonnull__(1)
__attribute__nonnull__(2);
min++;
if (flags & SCF_DO_STCLASS) {
bool invert = 0;
- SV* my_invlist = NULL;
+ SV* my_invlist = sv_2mortal(_new_invlist(0));
U8 namedclass;
/* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
/* FALL THROUGH */
case POSIXA:
if (FLAGS(scan) == _CC_ASCII) {
- my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
+ my_invlist = PL_XPosix_ptrs[_CC_ASCII];
}
else {
_invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
assert(flags & SCF_DO_STCLASS_OR);
ssc_union(data->start_class, my_invlist, invert);
}
- SvREFCNT_dec(my_invlist);
}
if (flags & SCF_DO_STCLASS_OR)
ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
*/
ssc_init(pRExC_state, data->start_class);
} else {
- /* AND before and after: combine and continue. These
- * assertions are zero-length, so can match an EMPTY
- * string */
+ /* AND before and after: combine and continue */
ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
- ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING;
}
}
}
if (f & SCF_DO_STCLASS_AND) {
ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
- ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING;
}
if (data) {
if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
ret = reg_node(pRExC_state, OPFAIL);
return ret;
}
- else if (min == max && RExC_parse < RExC_end && *RExC_parse == '?')
+ else if (min == max
+ && RExC_parse < RExC_end
+ && (*RExC_parse == '?' || *RExC_parse == '+'))
{
if (SIZE_ONLY) {
ckWARN2reg(RExC_parse + 1,
EBCDIC, but it works there, as the extra invariants
fold to themselves) */
*character = toFOLD((U8) code_point);
-
- /* We can downgrade to an EXACT node if this character
- * isn't a folding one. Note that this assumes that
- * nothing above Latin1 folds to some other invariant than
- * one of these alphabetics; otherwise we would also have
- * to check:
- * && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
- * || ASCII_FOLD_RESTRICTED))
- */
- if (downgradable && PL_fold[code_point] == code_point) {
+ if (downgradable
+ && *character == code_point
+ && ! HAS_NONLATIN1_FOLD_CLOSURE(code_point))
+ {
OP(node) = EXACT;
}
}
&& is_PROBLEMATIC_LOCALE_FOLD_cp(ender)))
{
if (UTF) {
-
- /* Normally, we don't need the representation of the
- * character in the sizing pass--just its size, but if
- * folding, we have to actually put the character out
- * even in the sizing pass, because the size could
- * change as we juggle things at the end of this loop
- * to avoid splitting a too-full node in the middle of
- * a potential multi-char fold [perl #123539] */
- const STRLEN unilen = (SIZE_ONLY && ! FOLD)
- ? UNISKIP(ender)
- : (uvchr_to_utf8((U8*)s, ender) - (U8*)s);
+ const STRLEN unilen = reguni(pRExC_state, ender, s);
if (unilen > 0) {
s += unilen;
len += unilen;
* cancel out the increment that follows */
len--;
}
- else if (FOLD) {
- /* See comment above for [perl #123539] */
- *(s++) = (char) ender;
- }
else {
REGC((char)ender, s++);
}
* at compile time. Besides not inverting folded locale now, we can't
* invert if there are things such as \w, which aren't known until runtime
* */
- if (cp_list
- && invert
+ if (invert
&& ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
&& ! depends_list
&& ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
Perl_save_re_context(pTHX)
{
dVAR;
- I32 nparens = -1;
- I32 i;
/* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
-
if (PL_curpm) {
const REGEXP * const rx = PM_GETRE(PL_curpm);
- if (rx)
- nparens = RX_NPARENS(rx);
- }
-
- /* RT #124109. This is a complete hack; in the SWASHNEW case we know
- * that PL_curpm will be null, but that utf8.pm and the modules it
- * loads will only use $1..$3.
- * The t/porting/re_context.t test file checks this assumption.
- */
- if (nparens == -1)
- nparens = 3;
-
- for (i = 1; i <= nparens; i++) {
- char digits[TYPE_CHARS(long)];
- const STRLEN len = my_snprintf(digits, sizeof(digits),
- "%lu", (long)i);
- GV *const *const gvp
- = (GV**)hv_fetch(PL_defstash, digits, len, 0);
-
- if (gvp) {
- GV * const gv = *gvp;
- if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
- save_scalar(gv);
- }
+ if (rx) {
+ U32 i;
+ for (i = 1; i <= RX_NPARENS(rx); i++) {
+ char digits[TYPE_CHARS(long)];
+ const STRLEN len = my_snprintf(digits, sizeof(digits),
+ "%lu", (long)i);
+ GV *const *const gvp
+ = (GV**)hv_fetch(PL_defstash, digits, len, 0);
+
+ if (gvp) {
+ GV * const gv = *gvp;
+ if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
+ save_scalar(gv);
+ }
+ }
+ }
}
}
#endif
PERL_ARGS_ASSERT_PUT_LATIN1_CHARCLASS_INNARDS;
for (i = 0; i < 256; i++) {
- if (BITMAP_TEST((U8 *) bitmap,i)) {
+ if (i < 256 && BITMAP_TEST((U8 *) bitmap,i)) {
/* The character at index i should be output. Find the next
* character that should NOT be output */
int j;
- for (j = i + 1; j < 256; j++) {
+ for (j = i + 1; j <= 256; j++) {
if (! BITMAP_TEST((U8 *) bitmap, j)) {
break;
}
evalbytes current_sub fc)],
"5.19" => [qw(say state switch unicode_strings unicode_eval
evalbytes current_sub fc)],
+ "5.21" => [qw(say state switch unicode_strings unicode_eval
+ evalbytes current_sub fc)],
);
# not actually used currently
__END__
package feature;
-our $VERSION = '1.36_01';
+our $VERSION = '1.37';
FEATURES
This feature is available from Perl 5.18 onwards.
-=head2 The 'postderef' and 'postderef_qq' features
-
-B<WARNING>: This feature is still experimental and the implementation may
-change in future versions of Perl. For this reason, Perl will
-warn when you use the feature, unless you have explicitly disabled the
-warning:
-
- no warnings "experimental::postderef";
-
-The 'postderef' feature allows the use of L<postfix dereference
-syntax|perlref/Postfix Dereference Syntax>. For example, it will make the
-following two statements equivalent:
-
- my @x = @{ $h->{a} };
- my @x = $h->{a}->@*;
-
-The 'postderef_qq' feature extends this, for array and scalar dereference, to
-working inside of double-quotish interpolations.
-
-This feature is available from Perl 5.20 onwards.
-
=head2 The 'signatures' feature
B<WARNING>: This feature is still experimental and the implementation may
goto fail;
}
- RX_MATCH_UTF8_set(rx,utf8_target);
reginfo->is_utf8_target = cBOOL(utf8_target);
reginfo->info_aux = NULL;
reginfo->strbeg = strbeg;
/* ml_anch: check after \n?
*
- * A note about PREGf_IMPLICIT: on an un-anchored pattern beginning
+ * A note about IMPLICIT: on an un-anchored pattern beginning
* with /.*.../, these flags will have been added by the
* compiler:
* /.*abc/, /.*abc/m: PREGf_IMPLICIT | PREGf_ANCH_MBOL
}
RX_MATCH_TAINTED_off(rx);
- RX_MATCH_UTF8_set(rx, utf8_target);
reginfo->prog = rx; /* Yes, sorry that this is confusing. */
reginfo->intuit = 0;
));
}
- /* Simplest case: anchored match need be tried only once, or with
- * MBOL, only at the beginning of each line.
- *
- * Note that /.*.../ sets PREGf_IMPLICIT|MBOL, while /.*.../s sets
- * PREGf_IMPLICIT|SBOL. The idea is that with /.*.../s, if it doesn't
- * match at the start of the string then it won't match anywhere else
- * either; while with /.*.../, if it doesn't match at the beginning,
- * the earliest it could match is at the start of the next line */
-
+ /* Simplest case: anchored match need be tried only once. */
+ /* [unless only anchor is BOL and multiline is set] */
if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) {
- char *end;
-
- if (regtry(reginfo, &s))
+ if (s == startpos && regtry(reginfo, &s))
goto got_it;
-
- if (!(prog->intflags & PREGf_ANCH_MBOL))
- goto phooey;
-
- /* didn't match at start, try at other newline positions */
-
- if (minlen)
- dontbother = minlen - 1;
- end = HOP3c(strend, -dontbother, strbeg) - 1;
-
- /* skip to next newline */
-
- while (s <= end) { /* note it could be possible to match at the end of the string */
- /* NB: newlines are the same in unicode as they are in latin */
- if (*s++ != '\n')
- continue;
- if (prog->check_substr || prog->check_utf8) {
- /* note that with PREGf_IMPLICIT, intuit can only fail
- * or return the start position, so it's of limited utility.
- * Nevertheless, I made the decision that the potential for
- * quick fail was still worth it - DAPM */
- s = re_intuit_start(rx, sv, strbeg, s, strend, flags, NULL);
- if (!s)
- goto phooey;
- }
- if (regtry(reginfo, &s))
- goto got_it;
- }
- goto phooey;
- } /* end anchored search */
-
- if (prog->intflags & PREGf_ANCH_GPOS)
+ else if (multiline || (prog->intflags & (PREGf_IMPLICIT | PREGf_ANCH_MBOL))) /* XXXX SBOL? */
+ {
+ char *end;
+
+ if (minlen)
+ dontbother = minlen - 1;
+ end = HOP3c(strend, -dontbother, strbeg) - 1;
+ /* for multiline we only have to try after newlines */
+ if (prog->check_substr || prog->check_utf8) {
+ /* because of the goto we can not easily reuse the macros for bifurcating the
+ unicode/non-unicode match modes here like we do elsewhere - demerphq */
+ if (utf8_target) {
+ if (s == startpos)
+ goto after_try_utf8;
+ while (1) {
+ if (regtry(reginfo, &s)) {
+ goto got_it;
+ }
+ after_try_utf8:
+ if (s > end) {
+ goto phooey;
+ }
+ if (prog->extflags & RXf_USE_INTUIT) {
+ s = re_intuit_start(rx, sv, strbeg,
+ s + UTF8SKIP(s), strend, flags, NULL);
+ if (!s) {
+ goto phooey;
+ }
+ }
+ else {
+ s += UTF8SKIP(s);
+ }
+ }
+ } /* end search for check string in unicode */
+ else {
+ if (s == startpos) {
+ goto after_try_latin;
+ }
+ while (1) {
+ if (regtry(reginfo, &s)) {
+ goto got_it;
+ }
+ after_try_latin:
+ if (s > end) {
+ goto phooey;
+ }
+ if (prog->extflags & RXf_USE_INTUIT) {
+ s = re_intuit_start(rx, sv, strbeg,
+ s + 1, strend, flags, NULL);
+ if (!s) {
+ goto phooey;
+ }
+ }
+ else {
+ s++;
+ }
+ }
+ } /* end search for check string in latin*/
+ } /* end search for check string */
+ else { /* search for newline */
+ if (s > startpos) {
+ /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
+ s--;
+ }
+ /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
+ while (s <= end) { /* note it could be possible to match at the end of the string */
+ if (*s++ == '\n') { /* don't need PL_utf8skip here */
+ if (regtry(reginfo, &s))
+ goto got_it;
+ }
+ }
+ } /* end search for newline */
+ } /* end anchored/multiline check string search */
+ goto phooey;
+ } else if (prog->intflags & PREGf_ANCH_GPOS)
{
/* PREGf_ANCH_GPOS should never be true if PREGf_GPOS_SEEN is not true */
assert(prog->intflags & PREGf_GPOS_SEEN);
if (RXp_PAREN_NAMES(prog))
(void)hv_iterinit(RXp_PAREN_NAMES(prog));
+ RX_MATCH_UTF8_set(rx, utf8_target);
+
/* make sure $`, $&, $', and $digit will work later */
if ( !(flags & REXEC_NOT_FIRST) )
S_reg_set_capture_string(aTHX_ rx,
char *gconvert(double, int, int, char *);
#endif
-#ifndef SV_COW_THRESHOLD
+#ifdef PERL_NEW_COPY_ON_WRITE
+# ifndef SV_COW_THRESHOLD
# define SV_COW_THRESHOLD 0 /* COW iff len > K */
-#endif
-#ifndef SV_COWBUF_THRESHOLD
+# endif
+# ifndef SV_COWBUF_THRESHOLD
# define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */
-#endif
-#ifndef SV_COW_MAX_WASTE_THRESHOLD
+# endif
+# ifndef SV_COW_MAX_WASTE_THRESHOLD
# define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
-#endif
-#ifndef SV_COWBUF_WASTE_THRESHOLD
+# endif
+# ifndef SV_COWBUF_WASTE_THRESHOLD
# define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
-#endif
-#ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
+# endif
+# ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
# define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
-#endif
-#ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
+# endif
+# ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
# define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
+# endif
#endif
/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
hold is 0. */
* has a mandatory return value, even though that value is just the same
* as the buf arg */
+#define V_Gconvert(x,n,t,b) \
+{ \
+ char *rc = (char *)Gconvert(x,n,t,b); \
+ PERL_UNUSED_VAR(rc); \
+}
+
+
#ifdef PERL_UTF8_CACHE_ASSERT
/* if adding more checks watch out for the following tests:
* t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
? count * body_size \
: FIT_ARENA0 (body_size)
#define FIT_ARENA(count,body_size) \
- (U32)(count \
+ count \
? FIT_ARENAn (count, body_size) \
- : FIT_ARENA0 (body_size))
+ : FIT_ARENA0 (body_size)
/* Calculate the length to copy. Specifically work out the length less any
final padding the compiler needed to add. See the comment in sv_upgrade
newlen++;
#endif
-#if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
-#define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
-#endif
-
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
if (newlen < minlen)
newlen = minlen;
-#ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
- if (SvLEN(sv)) {
+#ifndef Perl_safesysmalloc_size
+ if (SvLEN(sv))
newlen = PERL_STRLEN_ROUNDUP(newlen);
- }
#endif
if (SvLEN(sv) && s) {
s = (char*)saferealloc(s, newlen);
}
}
SvPV_set(sv, s);
-#ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
+#ifdef Perl_safesysmalloc_size
/* Do this here, do it once, do it right, and then we will never get
called back into sv_grow() unless there really is some growing
needed. */
/* some Xenix systems wipe out errno here */
#ifndef USE_LOCALE_NUMERIC
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
+ V_Gconvert(SvNVX(sv), NV_DIG, 0, s);
SvPOK_on(sv);
#else
{
DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
+ V_Gconvert(SvNVX(sv), NV_DIG, 0, s);
/* If the radix character is UTF-8, and actually is in the
* output, turn on the UTF-8 flag for the scalar */
and just use bytes. But some things that do fit into a byte are variants in
utf8, and the caller may not have been keeping track of these.)
-If the routine itself changes the string, it adds a trailing C<NUL>. Such a
-C<NUL> isn't guaranteed due to having other routines do the work in some input
-cases, or if the input is already flagged as being in utf8.
+If the routine itself changes the string, it adds a trailing NUL. Such a NUL
+isn't guaranteed due to having other routines do the work in some input cases,
+or if the input is already flagged as being in utf8.
The speed of this could perhaps be improved for many cases if someone wanted to
write a fast function that counts the number of variant characters in a string,
* set so starts from there. Otherwise, can use memory copy to
* get up to where we are now, and then start from here */
- if (invariant_head == 0) {
+ if (invariant_head <= 0) {
d = dst;
} else {
Copy(s, dst, invariant_head, char);
/* slated for free anyway (and not COW)? */
(sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
/* or a swipable TARG */
- || ((sflags & (SVs_PADTMP|SVs_PADMY|SVf_READONLY
- |SVf_IsCOW))
+ || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
== SVs_PADTMP
/* whose buffer is worth stealing */
&& CHECK_COWBUF_THRESHOLD(cur,len)
/*
=for apidoc sv_setpvn
-Copies a string (possibly containing embedded C<NUL> characters) into an SV.
-The C<len> parameter indicates the number of
+Copies a string into an SV. The C<len> parameter indicates the number of
bytes to be copied. If the C<ptr> argument is NULL the SV will become
undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
/*
=for apidoc sv_setpv
-Copies a string into an SV. The string must be terminated with a C<NUL>
-character.
-Does not handle 'set' magic. See C<sv_setpv_mg>.
+Copies a string into an SV. The string must be null-terminated. Does not
+handle 'set' magic. See C<sv_setpv_mg>.
=cut
*/
=for apidoc sv_usepvn_flags
Tells an SV to use C<ptr> to find its string value. Normally the
-string is stored inside the SV, but sv_usepvn allows the SV to use an
+string is stored inside the SV but sv_usepvn allows the SV to use an
outside string. The C<ptr> should point to memory that was allocated
-by L<Newx|perlclib/Memory Management and String Handling>. It must be
-the start of a Newx-ed block of memory, and not a pointer to the
-middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
-and not be from a non-Newx memory allocator like C<malloc>. The
-string length, C<len>, must be supplied. By default this function
-will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
+by C<malloc>. It must be the start of a mallocked block
+of memory, and not a pointer to the middle of it. The
+string length, C<len>, must be supplied. By default
+this function will realloc (i.e. move) the memory pointed to by C<ptr>,
so that pointer should not be freed or used by the programmer after
giving it to sv_usepvn, and neither should any pointers from "behind"
that pointer (e.g. ptr + 1) be used.
If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
-SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
+SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
will be skipped (i.e. the buffer is actually at least 1 byte longer than
C<len>, and already meets the requirements for storing in C<SvPVX>).
}
# endif
SvPV_set(sv, NULL);
- SvCUR_set(sv, 0);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
/* OK, so we don't need to copy our buffer. */
/*
=for apidoc sv_catpv
-Concatenates the C<NUL>-terminated string onto the end of the string which is
-in the SV.
+Concatenates the string onto the end of the string which is in the SV.
If the SV has the UTF-8 status set, then the bytes appended should be
valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
/*
=for apidoc sv_catpv_flags
-Concatenates the C<NUL>-terminated string onto the end of the string which is
-in the SV.
+Concatenates the string onto the end of the string which is in the SV.
If the SV has the UTF-8 status set, then the bytes appended should
be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
on the modified SV if appropriate.
Creates a new SV. A non-zero C<len> parameter indicates the number of
bytes of preallocated string space the SV should have. An extra byte for a
-trailing C<NUL> is also reserved. (SvPOK is not set for the SV even if string
+trailing NUL is also reserved. (SvPOK is not set for the SV even if string
space is allocated.) The reference count for the new SV is set to 1.
In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
PERL_ARGS_ASSERT_SV_MAGIC;
- if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
+ if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
|| ((flags = PL_magic_data[how]),
(vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
> magic_vtable_max))
/*
=for apidoc newSVpvn_flags
-Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
-characters) into it. The reference count for the
+Creates a new SV and copies a string into it. The reference count for the
SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
string. You are responsible for ensuring that the source string is at least
C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
/*
=for apidoc newSVpv
-Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
-characters) into it. The reference count for the
+Creates a new SV and copies a string into it. The reference count for the
SV is set to 1. If C<len> is zero, Perl will compute the length using
-strlen(), (which means if you use this option, that C<s> can't have embedded
-C<NUL> characters and has to have a terminating C<NUL> byte).
-
-For efficiency, consider using C<newSVpvn> instead.
+strlen(). For efficiency, consider using C<newSVpvn> instead.
=cut
*/
/*
=for apidoc newSVpvn
-Creates a new SV and copies a string into it, which may contain C<NUL> characters
+Creates a new SV and copies a buffer into it, which may contain NUL characters
(C<\0>) and other binary data. The reference count for the SV is set to 1.
Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
are responsible for ensuring that the source buffer is at least
/*
=for apidoc newSVpv_share
-Like C<newSVpvn_share>, but takes a C<NUL>-terminated string instead of a
+Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
string/length pair.
=cut
if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
/* 0, point, slack */
STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf));
+ V_Gconvert(nv, (int)digits, 0, ebuf);
sv_catpv_nomg(sv, ebuf);
if (*ebuf) /* May return an empty string for digits==0 */
return;
aka precis is 0 */
if ( c == 'g' && precis) {
STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf));
+ V_Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
/* May return an empty string for digits==0 */
if (*PL_efloatbuf) {
elen = strlen(PL_efloatbuf);
DIR *ret;
#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
+ int rc = 0;
DIR *pwd;
const Direntry_t *dirent;
char smallbuf[256];
/* Now we should have two dir handles pointing to the same dir. */
/* Be nice to the calling code and chdir back to where we were. */
+ rc = fchdir(my_dirfd(pwd));
/* XXX If this fails, then what? */
- PERL_UNUSED_RESULT(fchdir(my_dirfd(pwd)));
+ PERL_UNUSED_VAR(rc);
/* We have no need of the pwd handle any more. */
PerlDir_close(pwd);
new_arena->next = tbl->tbl_arena;
tbl->tbl_arena = new_arena;
tbl->tbl_arena_next = new_arena->array;
- tbl->tbl_arena_end = C_ARRAY_END(new_arena->array);
+ tbl->tbl_arena_end = new_arena->array
+ + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
}
tblent = tbl->tbl_arena_next++;
}
items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
while (items-- > 0) {
- *dst_ary++ = NULL;
+ *dst_ary++ = &PL_sv_undef;
}
}
else {
case SAVEt_CLEARPADRANGE:
break;
case SAVEt_HELEM: /* hash element */
- case SAVEt_SV: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
/* fall through */
case SAVEt_ITEM: /* normal string */
case SAVEt_GVSV: /* scalar slot in GV */
+ case SAVEt_SV: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- if (type == SAVEt_SV)
- break;
/* fall through */
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
case SAVEt_SVREF: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- if (type == SAVEt_SVREF)
- SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix));
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
break;
case SAVEt_AELEM: /* array element */
sv = (const SV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
av = (const AV *)POPPTR(ss,ix);
=for apidoc Am|char*|SvEND|SV* sv
Returns a pointer to the spot just after the last character in
the string which is in the SV, where there is usually a trailing
-C<NUL> character (even though Perl scalars do not strictly require it).
+null (even though Perl scalars do not strictly require it).
See C<SvCUR>. Access the character as *(SvEND(sv)).
Warning: If C<SvCUR> is equal to C<SvLEN>, then C<SvEND> points to
Set the value of the NV pointer in sv to val. See C<SvIV_set>.
=for apidoc Am|void|SvPV_set|SV* sv|char* val
-This is probably not what you want to use, you probably wanted
-L</sv_usepvn_flags> or L</sv_setpvn> or L</sv_setpvs>.
+Set the value of the PV pointer in sv to val. See also C<SvIV_set>.
-Set the value of the PV pointer in C<sv> to the Perl allocated
-C<NUL>-terminated string C<val>. See also C<SvIV_set>.
-
-Remember to free the previous PV buffer. There are many things to check.
Beware that the existing pointer may be involved in copy-on-write or other
mischief, so do C<SvOOK_off(sv)> and use C<sv_force_normal> or
C<SvPV_force> (or check the SvIsCOW flag) first to make sure this
-modification is safe. Then finally, if it is not a COW, call C<SvPV_free> to
-free the previous PV buffer.
+modification is safe.
=for apidoc Am|void|SvUV_set|SV* sv|UV val
Set the value of the UV pointer in sv to val. See C<SvIV_set>.
the SV if the SV does not contain a string. The SV may cache the
stringified version becoming C<SvPOK>. Handles 'get' magic. The
C<len> variable will be set to the length of the string (this is a macro, so
-don't use C<&len>). See also C<SvPVx> for a version which guarantees to
+don't use C<&len>). See also C<SvPVx> for a version which guarantees to
evaluate sv only once.
Note that there is no guarantee that the return value of C<SvPV()> is
=for apidoc Am|void|SvSetSV|SV* dsv|SV* ssv
Calls C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments
-more than once. Does not handle 'set' magic on the destination SV.
+more than once.
=for apidoc Am|void|SvSetSV_nosteal|SV* dsv|SV* ssv
Calls a non-destructive version of C<sv_setsv> if dsv is not the same as
=for apidoc Am|char *|SvGROW|SV* sv|STRLEN len
Expands the character buffer in the SV so that it has room for the
indicated number of bytes (remember to reserve space for an extra trailing
-C<NUL> character). Calls C<sv_grow> to perform the expansion if necessary.
+NUL character). Calls C<sv_grow> to perform the expansion if necessary.
Returns a pointer to the character
buffer. SV must be of type >= SVt_PV. One
alternative is to call C<sv_grow> if you are not sure of the type of SV.
/*
=for apidoc Am|SV*|newSVpvn_utf8|NULLOK const char* s|STRLEN len|U32 utf8
-Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
-characters) into it. If utf8 is true, calls
+Creates a new SV and copies a string into it. If utf8 is true, calls
C<SvUTF8_on> on the new SV. Implemented as a wrapper around C<newSVpvn_flags>.
=cut
print "not " unless (time
=>) eq time=>;
print "ok $test - => quotes keywords across lines\n"; $test++;
-
-# Used to crash [perl #123711]
-0-5x-l{0};
#!./perl
-# Test $/
+# Test $!
-print "1..39\n";
+print "1..48\n";
$test_count = 1;
$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
binmode TESTFILE;
test_record(*TESTFILE);
close TESTFILE;
+test_bad_setting();
$test_count_end = $test_count; # Needed to know how many tests to skip
-$/ = "\n";
-my $note = "\$/ preserved when set to bad value";
-# none of the setting of $/ to bad values should modify its value
-test_bad_setting();
-print +($/ ne "\n" ? "not " : "") .
- "ok $test_count # \$/ preserved when set to bad value\n";
-++$test_count;
# Now for the tricky bit--full record reading
if ($^O eq 'VMS') {
# ng: 'Missing $ on loop variable'
like $@, "^No such class a1b at ", 'TYPE of my of for statement';
-# Used to crash [perl #123542]
-eval 's /${<>{}) //';
-
-# Also used to crash [perl #123652]
-eval{$1=eval{a:}};
-
# Add new tests HERE (above this line)
# bug #74022: Loop on characters in \p{OtherIDContinue}
ok(!$st, 'read/die: read status');
ok(close($in), 'read/die: close status');
-# This used to be 1_000_000, but on Linux/ppc64 (POWER7) this kept
-# consistently failing. At exactly 0x100000 it started passing
-# again. We're hoping this number is bigger than any pipe buffer.
-my $surely_this_arbitrary_number_is_fine = 0x100000;
-
# close during print
fresh_io;
$SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
-$buf = "a" x $surely_this_arbitrary_number_is_fine . "\n";
+$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
select $out; $| = 1; select STDOUT;
alarm(1);
$st = print $out $buf;
fresh_io;
$SIG{ALRM} = sub { die };
-$buf = "a" x $surely_this_arbitrary_number_is_fine . "\n";
+$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
select $out; $| = 1; select STDOUT;
alarm(1);
$st = eval { print $out $buf };
elsif ($^O eq 'VMS') {
$wd = `show default`;
}
+elsif ($ENV{PWD}) {
+ $wd = $ENV{PWD};
+}
elsif ( $^O =~ /android/ || $^O eq 'nto' ) {
# On Android and Blackberry 10, pwd is a shell builtin, so plain `pwd`
# won't cut it
Use of assignment to $[ is deprecated at - line 2.
Assigning non-zero to $[ is no longer possible at - line 5.
b
-########
-# NAME $^H accidentally enabling all features
-eval 'BEGIN { $^H |= 0x1c020000 } $_ = evalbytes 12345';
-print $_||$@;
-EXPECT
-Number found where operator expected at (eval 1) line 1, near "evalbytes 12345"
- (Do you need to predeclare evalbytes?)
-syntax error at (eval 1) line 1, near "evalbytes 12345"
Non-string passed as bitmask [pp_sselect]
- %s too large [pp_gmtime]
-
- %s failed [pp_gmtime]
-
__END__
# pp_sys.c [pp_untie]
use warnings 'untie' ;
seekdir() attempted on invalid dirhandle $ｆｏｏ at - line 21.
rewinddir() attempted on invalid dirhandle $ｆｏｏ at - line 22.
closedir() attempted on invalid dirhandle $ｆｏｏ at - line 23.
-########
-# pp_sys.c [pp_gmtime]
-BEGIN {
- print <<EOM;
-SKIPPED
-# NaN values not produced consistently in 5.20.x
-EOM
- exit;
-}
-gmtime("NaN");
-localtime("NaN");
-use warnings "overflow";
-gmtime("NaN");
-localtime("NaN");
-
-EXPECT
-gmtime(NaN) too large at - line 6.
-gmtime(NaN) failed at - line 6.
-localtime(NaN) too large at - line 7.
-localtime(NaN) failed at - line 7.
-a;
;-a;
EXPECT
-########
-# toke.c
-# [perl #124113] Compile-time warning with UTF8 variable in array index
-use warnings;
-use utf8;
-my $𝛃 = 0;
-my @array = (0);
-my $v = $array[ 0 + $𝛃 ];
- $v = $array[ $𝛃 + 0 ];
-EXPECT
-########
-# toke.c
-# Allow Unicode here doc boundaries
-use warnings;
-use utf8;
-my $v = <<EnFraçais;
-Comme ca!
-EnFraçais
-print $v;
-EXPECT
-Comme ca!
-########
-# toke.c
-# Fix 'Use of "..." without parentheses is ambiguous' warning for
-# Unicode function names
-use utf8;
-use warnings;
-sub 𝛃(;$) { return 0; }
-my $v = 𝛃 - 5;
-EXPECT
-Warning: Use of "𝛃" without parentheses is ambiguous at - line 7.
plan(tests => 53 + 27*14);
-if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) {
- require Win32; # for IsAdminUser()
-}
-
# Tests presume we are in t/op directory and that file 'TEST' is found
# therein.
is(-d 'op', 1, "-d: directory correctly identified");
SKIP: {
my $restore_root;
- skip "Need Win32::IsAdminUser() on $^O", 1
- if $^O =~ /MSWin32|cygwin|msys/ && is_miniperl();
- my $Is_WinAdminUser = ($^O =~ /MSWin32|cygwin|msys/ and Win32::IsAdminUser()) ? 1 : 0;
- # TODO: skip("On an ACL filesystem like $^O we cannot rely on -w via uid/gid");
- # We have no filesystem check for ACL in core
- if ($Is_WinAdminUser) {
- skip("As Windows Administrator we cannot rely on -w via uid/gid");
- }
- elsif ($> == 0) {
+ if ($> == 0) {
# root can read and write anything, so switch uid (may not be
# implemented)
eval '$> = 1';
BEGIN { chdir 't'; require './test.pl'; }
-plan(tests => 11);
+plan(tests => 8);
{
no warnings 'deprecated';
."2.\n",
'no buffer corruption with multiline *{...expr...}'
;
-
-fresh_perl_is(
- '/$a[/<<a',
- "Missing right curly or square bracket at - line 1, within pattern\n" .
- "syntax error at - line 1, at EOF\n" .
- "Execution of - aborted due to compilation errors.\n",
- { stderr => 1 },
- '/$a[/<<a with no newline [perl #123712]'
-);
-fresh_perl_is(
- '/$a[m||/<<a',
- "Missing right curly or square bracket at - line 1, within pattern\n" .
- "syntax error at - line 1, at EOF\n" .
- "Execution of - aborted due to compilation errors.\n",
- { stderr => 1 },
- '/$a[m||/<<a with no newline [perl #123712]'
-);
-
-fresh_perl_is(
- '"@{"',
- "Missing right curly or square bracket at - line 1, within string\n" .
- "syntax error at - line 1, at EOF\n" .
- "Execution of - aborted due to compilation errors.\n",
- { stderr => 1 },
- '"@{" [perl #123712]'
-);
*bar::is = *is;
*bar::like = *like;
}
-plan 126;
+plan 120;
# -------------------- Errors with feature disabled -------------------- #
),
qr/syntax error/,
'referencing a state sub after a syntax error does not crash';
-{
- state $stuff;
- package A {
- state sub foo{ $stuff .= our $AUTOLOAD }
- *A::AUTOLOAD = \&foo;
- }
- A::bar();
- is $stuff, 'A::bar', 'state sub assigned to *AUTOLOAD can autoload';
-}
-{
- state sub quire{qr "quires"}
- package o { use overload qr => \&quire }
- ok "quires" =~ bless([], o::), 'state sub used as overload method';
-}
-{
- local $ENV{PERL5DB} = 'sub DB::DB{}';
- is(
- runperl(
- switches => [ '-d' ],
- progs => [ split "\n",
- 'use feature qw - lexical_subs state -;
- no warnings q-experimental::lexical_subs-;
- sub DB::sub{ print qq|4\n|; goto $DB::sub }
- state sub foo {print qq|2\n|}
- foo();
- '
- ],
- stderr => 1
- ),
- "4\n2\n",
- 'state subs and DB::sub under -d'
- );
-}
# -------------------- my -------------------- #
),
qr/syntax error/,
'referencing a my sub after a syntax error does not crash';
-{
- state $stuff;
- package A {
- my sub foo{ $stuff .= our $AUTOLOAD }
- *A::AUTOLOAD = \&foo;
- }
- A::bar();
- is $stuff, 'A::bar', 'my sub assigned to *AUTOLOAD can autoload';
-}
-{
- my sub quire{qr "quires"}
- package mo { use overload qr => \&quire }
- ok "quires" =~ bless([], mo::), 'my sub used as overload method';
-}
-
-{
- local $ENV{PERL5DB} = 'sub DB::DB{}';
- is(
- runperl(
- switches => [ '-d' ],
- progs => [ split "\n",
- 'use feature qw - lexical_subs state -;
- no warnings q-experimental::lexical_subs-;
- sub DB::sub{ print qq|4\n|; goto $DB::sub }
- my sub foo {print qq|2\n|}
- foo();
- '
- ],
- stderr => 1
- ),
- "4\n2\n",
- 'my subs and DB::sub under -d'
- );
-}
# -------------------- Interactions (and misc tests) -------------------- #
)
}
->(("${\''}")[0,0]);
-
-# [perl #122995] Hang when compiling while(1) in a sub-list
-# No ok() or is() necessary.
-sub foo { () = ($a, my $b, ($c, do { while(1) {} })) }
# argv[0] assignment and by calling prctl()
{
SKIP: {
- skip "We don't have prctl() here, or we're on Android", 2 unless $Config{d_prctl_set_name} && $^O ne 'android';
+ skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name};
# We don't really need these tests. prctl() is tested in the
# Kernel, but test it anyway for our sanity. If something doesn't
SKIP: {
skip("\$0 check only on Linux and FreeBSD", 2)
- unless $^O =~ /^(linux|android|freebsd)$/
+ unless $^O =~ /^(linux|freebsd)$/
&& open CMDLINE, "/proc/$$/cmdline";
chomp(my $line = scalar <CMDLINE>);
my $me = (split /\0/, $line)[0];
is $me, $0, 'altering $0 is effective (testing with /proc/)';
close CMDLINE;
- skip("\$0 check with 'ps' only on Linux (but not Android) and FreeBSD", 1) if $^O eq 'android';
# perlbug #22811
my $mydollarzero = sub {
my($arg) = shift;
require 'test.pl';
}
use warnings;
-plan( tests => 183 );
+plan( tests => 182 );
# these shouldn't hang
{
@b = sort CORE::reverse (4,1,3,2);
cmp_ok("@b",'eq','1 2 3 4','CORE::reverse then sort');
-eval { @b = sort CORE::revers (4,1,3,2); };
-like($@, qr/^Undefined sort subroutine "CORE::revers" called at /);
sub twoface { no warnings 'redefine'; *twoface = sub { $a <=> $b }; &twoface }
$Is_UFS = $Is_Darwin && (() = `df -t ufs . 2>/dev/null`) == 2;
-if ($Is_Cygwin && !is_miniperl) {
+if ($Is_Cygwin) {
require Win32;
Win32->import;
}
# Going to try to switch away from root. Might not work.
my $olduid = $>;
eval { $> = 1; };
- skip "Can't test if an admin user in miniperl", 2,
- if $Is_Cygwin && is_miniperl();
skip "Can't test -r or -w meaningfully if you're superuser", 2
if ($Is_Cygwin ? Win32::IsAdminUser : $> == 0);
my $s2 = -s _;
is($s1, $s2, q(-T _ doesn't break the statbuffer));
SKIP: {
- my $root_uid = $Is_Cygwin ? 18 : 0;
skip "No lstat", 1 unless $Config{d_lstat};
- skip "uid=0", 1 if $< == $root_uid or $> == $root_uid;
- skip "Can't check if admin user in miniperl", 1
- if $^O =~ /^(cygwin|MSWin32|msys)$/ && is_miniperl();
- skip "Readable by group/other means readable by me on $^O", 1 if $^O eq 'VMS'
- or ($^O =~ /^(cygwin|MSWin32|msys)$/ and Win32::IsAdminUser());
+ skip "uid=0", 1 unless $<&&$>;
+ skip "Readable by group/other means readable by me", 1 if $^O eq 'VMS';
lstat($tmpfile);
-T _;
ok(eval { lstat _ },
use strict;
-plan tests => 137;
+plan tests => 136;
# Before loading feature.pm, test it with CORE::
ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope';
thing2(6);
}
-# [perl #123029] regression in "state" under PERL_NO_COW
-sub rt_123029 {
- state $s;
- $s = 'foo'x500;
- my $c = $s;
- return defined $s;
-}
-ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
__DATA__
state ($a) = 1;
require './test.pl';
}
-plan( tests => 36 );
+plan( tests => 33 );
sub empty_sub {}
is $str[1], $str[0],
'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
}
-
-# RT #124156 death during unwinding causes crash
-# the tie allows us to trigger another die while cleaning up the stack
-# from an earlier die.
-
-{
- package RT124156;
-
- sub TIEHASH { bless({}, $_[0]) }
- sub EXISTS { 0 }
- sub FETCH { undef }
- sub STORE { }
- sub DELETE { die "outer\n" }
-
- my @value;
- eval {
- @value = sub {
- @value = sub {
- my %a;
- tie %a, "RT124156";
- local $a{foo} = "bar";
- die "inner";
- ("dd2a", "dd2b");
- }->();
- ("cc3a", "cc3b");
- }->();
- };
- ::is($@, "outer\n", "RT124156 plain");
-
- my $destroyed = 0;
- sub DESTROY { $destroyed = 1 }
-
- sub f {
- my $x;
- my $f = sub {
- $x = 1; # force closure
- my %a;
- tie %a, "RT124156";
- local $a{foo} = "bar";
- die "inner";
- };
- bless $f, 'RT124156';
- $f->();
- }
-
- eval { f(); };
- # as opposed to $@ eq "Can't undef active subroutine"
- ::is($@, "outer\n", "RT124156 depth");
- ::is($destroyed, 1, "RT124156 freed cv");
-}
use Config;
-plan tests => 128;
+plan tests => 127;
# 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
eleak(2,0,'/[[:ascii:]]/');
eleak(2,0,'/[[.zog.]]/');
eleak(2,0,'/[.zog.]/');
-eleak(2,0,'/|\W/', '/|\W/ [perl #123198]');
eleak(2,0,'no warnings; /(?[])/');
eleak(2,0,'no warnings; /(?[[a]+[b]])/');
eleak(2,0,'no warnings; /(?[[a]-[b]])/');
use strict;
use Config;
-plan tests => 801;
+plan tests => 800;
$| = 1;
local $ENV{PATH} = $tmp;
is(eval { `$echo 1` }, undef);
- # Message can be different depending on whether echo
- # is a builtin or not
- like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH}/);
+ like($@, qr/^Insecure directory in \$ENV\{PATH}/);
}
SKIP: {
$_ = "$TAINT".reset "x";
is eval { eval $::x.1 }, 1, 'reset does not taint undef';
-# [perl #122669]
-{
- # See the comment above the first formline test.
- local $ENV{PATH} = $ENV{PATH};
- $ENV{PATH} = $old_env_path if $Is_MSWin32;
- is runperl(
- switches => [ '-T' ],
- prog => 'use constant K=>$^X; 0 if K; BEGIN{} use strict; '
- .'print 122669, qq-\n-',
- stderr => 1,
- ), "122669\n",
- 'tainted constant as logop condition should not prevent "use"';
-}
-
# This may bomb out with the alarm signal so keep it last
SKIP: {
skip "No alarm()" unless $Config{d_alarm};
skip_all_without_config('useithreads');
skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
- plan(28);
+ plan(27);
}
use strict;
'no crash when deleting $::{INC} in thread'
);
-fresh_perl_is(<<'CODE', 'ok', 'no crash modifying extended array element');
-use threads;
-my @a = 1;
-threads->create(sub { $#a = 1; $a[1] = 2; print qq/ok\n/ })->join;
-CODE
-
# EOF
require './test.pl';
}
-plan tests => 72;
+plan tests => 66;
# These tests make sure, among other things, that we don't end up
# burning tons of CPU for dates far in the future.
|| $small_time == $smallest
|| $big_time - 200 != $biggest
|| $big_time == $biggest) {
- skip "Can't represent test values", 8;
+ skip "Can't represent test values", 4;
}
my $small_time_f = sprintf("%.0f", $small_time);
my $big_time_f = sprintf("%.0f", $big_time);
$warning = '';
my $date = gmtime($big_time);
like $warning, qr/^gmtime\($big_time_f\) too large/;
- like $warning, qr/^gmtime\($big_time_f\) failed/m;
$warning = '';
$date = localtime($big_time);
like $warning, qr/^localtime\($big_time_f\) too large/;
- like $warning, qr/^localtime\($big_time_f\) failed/m;
$warning = '';
$date = gmtime($small_time);
like $warning, qr/^gmtime\($small_time_f\) too small/;
- like $warning, qr/^gmtime\($small_time_f\) failed/m;
$warning = '';
$date = localtime($small_time);
like $warning, qr/^localtime\($small_time_f\) too small/;
- like $warning, qr/^localtime\($small_time_f\) failed/m;
-}
-
-{
- local $^W;
- scalar gmtime("NaN");
- pass('[perl #123495] gmtime(NaN) does not crash');
- scalar localtime("NaN");
- pass('localtime(NaN) does not crash');
+
}
}
require './test.pl';
-plan(tests => 3*10 + 3*8 + 2*16 + 3);
+plan(tests => 3*10 + 3*8 + 2*16 + 2);
my $arg = $ENV{PATH}; # a tainted value
use constant UTF8 => "\x{1234}";
'ok', {switches => ["-T", "-l"]},
"therefore swash_init should be taint agnostic");
}
-
-{
- # RT #122148: s///e on tainted utf8 strings got pos() messed up in 5.20
-
- my @p;
- my $s = "\x{100}\x{100}\x{100}\x{100}". $^X;
- $s =~ s/\x{100}/push @p, pos($s); "xxxx";/eg;
- is("@p", "0 1 2 3", "RT #122148");
-}
my $bas_tests = 21;
# number of tests in section 3
-my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 11 + 3;
+my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 11;
# number of tests in section 4
my $hmb_tests = 37;
is $x, undef, 'formats in subs do not leak';
}
-fresh_perl_is(<<'EOP', <<'EXPECT',
-use warnings 'syntax' ;
-format STDOUT =
-^*|^*
-my $x = q/dd/, $x
-.
-write;
-EOP
-dd|
-EXPECT
- { stderr => 1 }, '#123245 panic in sv_chop');
-
-fresh_perl_is(<<'EOP', <<'EXPECT',
-use warnings 'syntax' ;
-format STDOUT =
-^*|^*
-my $x = q/dd/
-.
-write;
-EOP
-Not enough format arguments at - line 4.
-dd|
-EXPECT
- { stderr => 1 }, '#123245 different panic in sv_chop');
-
-fresh_perl_is(<<'EOP', <<'EXPECT',
-format STDOUT =
-# x at the end to make the spaces visible
-@... x
-q/a/
-.
-write;
-EOP
-a x
-EXPECT
- { stderr => 1 }, '#123538 crash in FF_MORE');
#############################
## Section 4
use strict;
-plan 9;
+plan 5;
-my $err;
-my $err1 = "Unimplemented at $0 line ";
-my $err2 = ".\n";
+my $err = "Unimplemented at $0 line " . ( __LINE__ + 2 ) . ".\n";
-$err = $err1 . ( __LINE__ + 1 ) . $err2;
eval { ... };
-is $@, $err, "Execution of ellipsis statement reported 'Unimplemented' code";
-$@ = '';
-note("RT #122661: Semicolon before ellipsis statement disambiguates to indicate block rather than hash reference");
-my @input = (3..5);
-my @transformed;
-$err = $err1 . ( __LINE__ + 1 ) . $err2;
-eval { @transformed = map {; ... } @input; };
-is $@, $err, "Disambiguation case 1";
-$@ = '';
+is $@, $err;
-$err = $err1 . ( __LINE__ + 1 ) . $err2;
-eval { @transformed = map {;...} @input; };
-is $@, $err, "Disambiguation case 2";
-$@ = '';
-
-$err = $err1 . ( __LINE__ + 1 ) . $err2;
-eval { @transformed = map {; ...} @input; };
-is $@, $err, "Disambiguation case 3";
-$@ = '';
-
-$err = $err1 . ( __LINE__ + 1 ) . $err2;
-eval { @transformed = map {;... } @input; };
-is $@, $err, "Disambiguation case 4";
-$@ = '';
#
# Regression tests, making sure ... is still parsable as an operator.
+++ /dev/null
-#!./perl -T
-#
-# All the tests in this file are ones that run exceptionally slowly
-# (each test taking seconds or even minutes) in the absence of particular
-# optimisations. Thus it is a sort of canary for optimisations being
-# broken.
-#
-# Although it includes a watchdog timeout, this is set to a generous limit
-# to allow for running on slow systems; therefore a broken optimisation
-# might be indicated merely by this test file taking unusually long to
-# run, rather than actually timing out.
-#
-# This is similar to t/perf/speed.t but tests performance regressions specific
-# to taint.
-#
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = ('../lib');
- require Config; import Config;
- require './test.pl';
-}
-
-use strict;
-use warnings;
-use Scalar::Util qw(tainted);
-
-$| = 1;
-
-plan tests => 2;
-
-watchdog(60);
-
-{
- my $in = substr($ENV{PATH}, 0, 0) . ( "ab" x 200_000 );
- utf8::upgrade($in);
- ok(tainted($in), "performance issue only when tainted");
- while ($in =~ /\Ga+b/g) { }
- pass("\\G on tainted string");
-}
-
-1;
require 't/test.pl';
-plan(tests => 6);
+plan(tests => 5);
use_ok('Module::CoreList');
use_ok('Module::CoreList::Utils');
-use_ok('Module::CoreList::TieHashDelta');
{
no warnings 'once';
-CPAN cpan/CPAN/lib/CPAN/Author.pm 792d7c8fbe6ed45e1244e589a8b712878c5dd2a5
-CPAN cpan/CPAN/lib/CPAN/CacheMgr.pm 132adb7f96014ec7ded45457044ed925d3181475
-CPAN cpan/CPAN/lib/CPAN/FTP.pm 3f0d5fc572c8749a566d73ca892c6c89ce3fb676
-CPAN cpan/CPAN/lib/CPAN/HandleConfig.pm e52052b6ef6d1d664f0ffa6cf01d48a8d1321520
-CPAN cpan/CPAN/lib/CPAN/HTTP/Client.pm 242842ca566fd8e3d776deb549ff758a571ca2e3
-CPAN cpan/CPAN/lib/CPAN/Index.pm 73aee30450127c5ac4dc05abc2c10a8accd4b198
-CPAN cpan/CPAN/lib/CPAN/LWP/UserAgent.pm e09525b0c2377c5ac28b7fad1b6d70c57e343913
-CPAN cpan/CPAN/lib/CPAN/Mirrors.pm 580e74746abaf1628d533015d5b529d82a470af4
Digest::MD5 cpan/Digest-MD5/t/files.t bdbe05b705d9da305fedce7a9f4b6ba63250c7cf
Encode cpan/Encode/bin/enc2xs f60036fd3574ec05c9aab7f4db00a828d5dea92d
Encode cpan/Encode/Byte/Makefile.PL 0986e25f981a3bf182a13a0060d28d4efedd87e6
Encode cpan/Encode/TW/Makefile.PL 0cc44f95e59f45c0fb3b66bde41525f13c19a25c
Module::Build cpan/Module-Build/lib/Module/Build/ConfigData.pm 85eb9656e68d1f256737dc52d86b5d0fed28f832
PerlIO::via::QuotedPrint cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t ca39f0146e89de02c746e199c45dcb3e5edad691
-Pod::Parser cpan/Pod-Parser/lib/Pod/PlainText.pm f0b490545b4e52e141450d1192d0ca00bd8d7a82
Text::Balanced cpan/Text-Balanced/t/01_compile.t 1598cf491a48fa546260a2ec41142abe84da533d
Text::Balanced cpan/Text-Balanced/t/02_extbrk.t 6ba1b64a4604e822dc2260b8ffcea6b406339ee8
Text::Balanced cpan/Text-Balanced/t/03_extcbk.t 3307c980af28963414cab799c427b359ef3b8657
libnet cpan/libnet/Makefile.PL 13a8e4a8c7fb2607219c3106cad6c3d7173f7221
podlators cpan/podlators/scripts/pod2man.PL f81acf53f3ff46cdcc5ebdd661c5d13eb35d20d6
podlators cpan/podlators/scripts/pod2text.PL b4693fcfe4a0a1b38a215cfb8985a65d5d025d69
-version cpan/version/lib/version.pm d0923b895d57f1d669ae36fcf85c87b16db341d1
+version cpan/version/lib/version.pm fa9931d4db05aff9a0a6ef558610b1a472d9306e
+version vutil.c 238196173eb90dea388443213a4b968323474874
+version vxs.inc 9064aacbdfe42bb584a068f62b505dd11dbb4dc4
Can't get short module name from a handle
Can't load DLL `%s', possible problematic module `%s'
Can't locate %s: %s
+Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
Can't pipe "%s": %s
Can't set type on DOS
Can't spawn: %s
Carp::Always
Carp::Assert
Carp::Clan
+CGI
chcp(1)
Class::Accessor
Class::C3
kill(3)
langinfo(3)
LaTeX::Encode
-Lingua::JA::Romanize::Japanese
Lingua::KO::Hangul::Util
-Lingua::KO::Romanize::Hangul
-Lingua::ZH::Romanize::Pinyin
List::Gather
local::lib
Log::Message
Math::TrulyRandom
md5sum(1)
mmap(2)
+Module::Build
Module::CPANTS::Analyse
Module::Find
Module::Info
open(2)
OS2::Proc
OS2::WinObject
+Package::Constants
PadWalker
passwd(1)
perl(1)
Tk
Tk::Pod
tty(1)
-Unicode::CaseFold
Unicode::Casing
-Unicode::GCString
Unicode::LineBreak
Unicode::Regex::Set
Unicode::Semantics
-Unicode::Tussle
Unicode::Unihan
unzip(1)
Version::Requirements
print "1..0 # Not all files are available during cross-compilation\n";
exit 0;
}
- if ($^O eq 'dec_osf') {
- print "1..0 # $^O cannot handle this test\n";
- exit 0;
- }
require '../regen/regen_lib.pl';
}
+++ /dev/null
-#!./perl -w
-#
-# Check that utf8.pm and its dependencies only use the subset of the
-# $1..$n capture vars that Perl_save_re_context() is hard-coded to
-# localise, because that function has no efficient way of determining at
-# runtime what vars to localise.
-#
-# Note that this script tests for the existence of symbol table entries in
-# %::, so @4 etc would trigger a failure as well as $4.
-#
-# If tests start to fail, either (in order of descending preference):
-#
-# * fix utf8.pm or its dependencies so that any recent change no longer
-# uses more special vars (ideally it would use no vars);
-#
-# * fix Perl_save_re_context() so that it localises more vars, then
-# update this test script with the new relaxed var list.
-
-
-use warnings;
-use strict;
-
-# trigger the dependency loading
-
-my $x = lc "\x{411}";
-
-# determine which relevant vars those dependencies accessed
-
-my @vars =
- grep !/^[0123]$/, # $0, and $1, ..$3 allowed
- grep /^(?:\d+|[`'&])$/, # numeric and $`, $&, $' vars
- sort keys %::;
-
-# load any other modules *after* calculating @vars
-
-require './test.pl';
-
-plan(1);
-
-is(scalar @vars, 0, "extraneous vars")
- or diag("extra vars seen: " . join(", ", map "*$_", @vars));
-
-exit 0;
if ( $^O eq "VMS" ) {
skip_all( "- regen.pl needs porting." );
}
-if ($^O eq 'dec_osf') {
- skip_all("$^O cannot handle this test");
-}
use Config;
if ( $Config{usecrosscompile} ) {
skip_all( "Not all files are available during cross-compilation" );
require './test.pl';
require Config; import Config;
skip_all_if_miniperl("no dynamic loading on miniperl, no Encode nor POSIX");
- if ($^O eq 'dec_osf') {
- skip_all("$^O cannot handle this test");
- }
require './loc_tools.pl';
}
require './test.pl';
}
-plan tests => 726; # Update this when adding/deleting tests.
+plan tests => 721; # Update this when adding/deleting tests.
run_tests() unless caller;
- { # Was getting optimized into EXACT (non-folding node)
- my $x = qr/[x]/i;
- utf8::upgrade($x);
- like("X", qr/$x/, "UTF-8 of /[x]/i matches upper case");
- }
-
- { # [perl #123539]
- like("TffffffffffffTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff", qr/TffffffffffffTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff/il, "");
- like("TffffffffffffT\x{100}TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff", qr/TffffffffffffT\x{100}TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff/il, "");
- }
-
- { # [perl #123604]
- my($s, $x, @x) = ('abc', 'a', 'd');
- my $long = 'b' x 2000;
- my $eval = q{$s =~ m{$x[bbb]c} ? 1 : 0};
- $eval =~ s{bbb}{$long};
- my $match = eval $eval;
- ok(1, "did not crash");
- ok($match, "[bbb...] resolved as character class, not subscript");
- }
} # End of sub run_tests
1;
}
{
- fresh_perl_is(<<'EOF',
- my $s = "\x{41c}";
- $s =~ /(.*)/ or die;
- $ls = lc $1;
- print $ls eq lc $s ? "good\n" : "bad: [$ls]\n";
-EOF
- "good\n",
- {},
- "swash triggered by lc() doesn't corrupt \$1"
- );
- }
-
- {
#' RT #119075
no warnings 'regexp'; # Silence "has useless greediness modifier"
local $@;
is($word, 'раб', "Handles UTF8 trie correctly");
}
- { # [perl #122460]
- my $a = "rdvark";
- $a =~ /(?{})(?=[A-Za-z0-9_])a*?/g;
- is (pos $a, 0, "optimizer correctly thinks (?=...) is 0-length");
- }
-
#
# Keep the following tests last -- they may crash perl
#
chdir 't' if -d 't';
@INC = ('../lib','.');
require './test.pl';
- if ($^O eq 'dec_osf') {
- skip_all("$^O cannot handle this test");
- }
}
skip_all('$PERL_SKIP_PSYCHO_TEST set') if $ENV{PERL_SKIP_PSYCHO_TEST};
-
plan tests => 15; # Update this when adding/deleting tests.
run_tests() unless caller;
[bcd].{2,3}aaaa Xb\x{100}aaaaa y - -
'\Awibble\z'm wibble y - -
/(alias|status)es$/i Statuses y $1 Status # [perl #121778]
-(.)(?{$~=$^N}) \x{100} y $~ \x{100} # [perl #123135]
-
-/(a+){1}+a/ aaa n - - # [perl #125825]
# Keep these lines at the end of the file
# vim: softtabstop=0 noexpandtab
'Useless (?c) - use /gc modifier {#} m/(?ogc{#})/',
],
'/a{1,1}?/' => 'Useless use of greediness modifier \'?\' {#} m/a{1,1}?{#}/',
+ '/b{3} +/x' => 'Useless use of greediness modifier \'+\' {#} m/b{3} +{#}/',
);
my @warnings_utf8 = mark_as_utf8(
+++ /dev/null
-#!./perl
-use strict;
-use warnings;
-
-$| = 1;
-
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = ('../lib','.','../ext/re');
- require './test.pl';
-}
-
-plan tests => 3;
-use strict;
-
-my(@body) = (
- "<mailto:xxxx.xxxx\@outlook.com>",
- "A\x{B9}ker\x{E8}eva xxxx.xxxx\@outlook.com \x{201D}",
-);
-
-for (@body) {
- s{ <? (?<!mailto:) \b ( [a-z0-9.]+ \@ \S+ ) \b
- (?: > | \s{1,10} (?!phone) [a-z]{2,11} : ) }{ }xgi;
- my $got= $1;
- is( $got, '.xxxx@outlook.com' );
-}
-ok("got to the end without dieing (note without DEBUGGING passing this test means nothing)");
-
require './test.pl';
}
-plan tests => 42;
+plan tests => 40;
$^R = undef;
like( 'a', qr/^a(?{1})(?:b(?{2}))?/, 'a =~ ab?' );
# [perl #78194] $_ in code block aliasing op return values
"$_" =~ /(?{ is \$_, \$_,
'[perl #78194] \$_ == \$_ when $_ aliases "$x"' })/;
-
-@a = 1..3;
-like eval { qr/@a(?{})/ }, qr/1 2 3\(\?\{\}\)/, 'qr/@a(?{})/';
-
-# Not a code block, but looks a bit like one. (Failed an assertion from
-# 5.17.1 to 5.21.6.)
-ok "(?{" =~ qr/\Q(?{/, 'qr/\Q(?{/';
use warnings;
no warnings 'once';
-if ($^O eq 'dec_osf') {
- print "1..0 # $^O cannot handle this test\n";
- exit(0);
-}
-
# This is a wrapper for a generated file. Assumes being run from 't'
# directory.
EOF
"", {}, "no locales where LC_NUMERIC breaks");
-SKIP: {
- skip("Windows stores locale defaults in the registry", 1 )
- if $^O eq 'MSWin32';
+{
local $ENV{LC_NUMERIC}; # So not taken as a default
local $ENV{LC_ALL}; # so it never overrides LC_NUMERIC
local $ENV{LANG}; # So not taken as a default
# This test depends on t/lib/Devel/switchd*.pm.
-plan(tests => 20);
+plan(tests => 18);
my $r;
"42\n",
'UTF8 length caches on $DB::sub are flushed'
);
-
-# [perl #122771] -d conflicting with sort optimisations
-is(
- runperl(
- switches => [ '-Ilib', '-d:switchd_empty' ],
- prog => 'BEGIN { $^P &= ~0x4 } sort { $$b <=> $$a } (); print qq-42\n-',
- ),
- "42\n",
- '-d does not conflict with sort optimisations'
-);
-
-# [perl #123748]
-#
-# On some platforms, it's possible that calls to getenv() will
-# return a pointer to statically allocated data that may be
-# overwritten by subsequent calls to getenv/putenv/setenv/unsetenv.
-#
-# In perl.c, s = PerlEnv_GetEnv("PERL5OPT") is called, and
-# then moreswitches(s), which, if -d:switchd_empty is given,
-# will call my_setenv("PERL5DB", "use Devel::switchd_empty"),
-# and then return to continue parsing s.
-{
-local $ENV{PERL5OPT} = '-d:switchd_empty';
-
-like(
- runperl(
- switches => [ '-Ilib' ], prog => 'print q(hi)',
- ),
- qr/hi/,
- 'putenv does not interfere with PERL5OPT parsing',
-);
-}
# define ALLOC_THREAD_KEY \
STMT_START { \
if (pthread_key_create(&PL_thr_key, 0)) { \
- PERL_UNUSED_RESULT(write(2, STR_WITH_LEN("panic: pthread_key_create failed\n"))); \
+ int rc; \
+ rc = write(2, STR_WITH_LEN("panic: pthread_key_create failed\n")); \
+ PERL_UNUSED_VAR(rc); \
exit(1); \
} \
} STMT_END
Direct pointer to the end of the chunk of text currently being lexed, the
end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
-+ SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
++ SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
always located at the end of the buffer, and does not count as part of
the buffer's contents.
=for apidoc Amx|char *|lex_grow_linestr|STRLEN len
Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
-at least I<len> octets (including terminating C<NUL>). Returns a
+at least I<len> octets (including terminating NUL). Returns a
pointer to the reallocated buffer. This is necessary before making
any direct modification of the buffer that would increase its length.
L</lex_stuff_pvn> provides a more convenient way to insert text into
*/
#define LEX_FAKE_EOF 0x80000000
-#define LEX_NO_TERM 0x40000000 /* here-doc */
+#define LEX_NO_TERM 0x40000000
bool
Perl_lex_next_chunk(pTHX_ U32 flags)
bool got_some;
if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
- if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
- return FALSE;
linestr = PL_parser->linestr;
buf = SvPVX(linestr);
if (!(flags & LEX_KEEP_PREVIOUS) &&
STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
PL_bufptr = s;
lex_read_space(flags | LEX_KEEP_PREVIOUS |
- (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
+ (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
LEX_NO_NEXT_CHUNK : 0));
s = PL_bufptr;
PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
PL_last_uni++;
s = PL_last_uni;
while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
- s += UTF ? UTF8SKIP(s) : 1;
+ s++;
if ((t = strchr(s, '(')) && t < PL_bufptr)
return;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
if (check_keyword) {
char *s2 = PL_tokenbuf;
- STRLEN len2 = len;
if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
- s2 += 6, len2 -= 6;
- if (keyword(s2, len2, 0))
+ s2 += 6, len -= 6;
+ if (keyword(s2, len, 0))
return start;
}
start_force(PL_curforce);
PL_bufend = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
PL_expect = XOPERATOR;
+ PL_sublex_info.sub_inwhat = 0;
return ')';
}
}
&& !(last_un_char == '$' || last_un_char == '@'
|| last_un_char == '&')
&& isALPHA(*s) && s[1] && isALPHA(s[1])) {
- char *d = s;
+ char *d = tmpbuf;
while (isALPHA(*s))
- s++;
- if (keyword(d, s - d, 0))
+ *d++ = *s++;
+ *d = '\0';
+ if (keyword(tmpbuf, d - tmpbuf, 0))
weight -= 150;
}
if (un_char == last_un_char + 1)
if (PL_madskills)
PL_faketokens = 0;
#endif
- if ((!PL_rsfp || PL_lex_inwhat)
- && (!PL_parser->filtered || s+1 < PL_bufend)) {
+ if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
PL_last_uni = 0;
PL_last_lop = 0;
if (PL_lex_brackets &&
}
switch (PL_expect) {
case XTERM:
- case XTERMORDORDOR:
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
PL_lex_allbrackets++;
OPERATOR(HASHBRACK);
char *t = s+1;
while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
- t += UTF ? UTF8SKIP(t) : 1;
+ t++;
if (*t++ == ',') {
PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
while (t < PL_bufend && *t != ']')
term = '"';
if (!isWORDCHAR_lazy_if(s,UTF))
deprecate("bare << to mean <<\"\"");
- peek = s;
- while (isWORDCHAR_lazy_if(peek,UTF)) {
- peek += UTF ? UTF8SKIP(peek) : 1;
+ for (; isWORDCHAR_lazy_if(s,UTF); s++) {
+ if (d < e)
+ *d++ = *s;
}
- len = (peek - s >= e - d) ? (e - d) : (peek - s);
- Copy(s, d, len, char);
- s += len;
- d += len;
}
if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
Perl_croak(aTHX_ "Delimiter for here document is too long");
* 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 "/usr/local/lib/perl5/5.20/unknown" / **/
-/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.20/unknown" / **/
+/*#define ARCHLIB "/usr/local/lib/perl5/5.21/unknown" / **/
+/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.21/unknown" / **/
/* 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 "/usr/local/lib/perl5/5.20" /**/
-#define PRIVLIB_EXP "/usr/local/lib/perl5/5.20" /**/
+#define PRIVLIB "/usr/local/lib/perl5/5.21" /**/
+#define PRIVLIB_EXP "/usr/local/lib/perl5/5.21" /**/
/* CAN_PROTOTYPE:
* If defined, this macro indicates that the C compiler can handle
* 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 "/usr/local/lib/perl5/5.20/unknown" / **/
-/*#define SITEARCH_EXP "/usr/local/lib/perl5/5.20/unknown" / **/
+/*#define SITEARCH "/usr/local/lib/perl5/5.21/unknown" / **/
+/*#define SITEARCH_EXP "/usr/local/lib/perl5/5.21/unknown" / **/
/* 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 "/usr/local/lib/perl5/5.20" /**/
-#define SITELIB_EXP "/usr/local/lib/perl5/5.20" /**/
+#define SITELIB "/usr/local/lib/perl5/5.21" /**/
+#define SITELIB_EXP "/usr/local/lib/perl5/5.21" /**/
#define SITELIB_STEM "/usr/local/lib/perl5" /**/
/* Size_t_size:
#endif
/* Generated from:
- * 7557e985de18f71e80f627226b454bc8eaf20477dcf0c45b5b2c51ec792f5c89 config_h.SH
- * dbc8d38ba52ae23e5423418bb3f56b1b6fcdaa82cf71ba0be3463e8221bfe0c0 uconfig.sh
+ * 986d2349e078df67f02d5b9747b7fe65abb0d2875fb52a836138919aafe08545 config_h.SH
+ * a61a38253be27e9d2b4ff63b9f34ef9c6870a03037609f2c89840ad890a7aef8 uconfig.sh
* ex: set ro: */
afsroot='/afs'
alignbytes='4'
aphostname='/bin/hostname'
-archlib='/usr/local/lib/perl5/5.20/unknown'
-archlibexp='/usr/local/lib/perl5/5.20/unknown'
+archlib='/usr/local/lib/perl5/5.21/unknown'
+archlibexp='/usr/local/lib/perl5/5.21/unknown'
archname='unknown'
asctime_r_proto='0'
bin='/usr/local/bin'
perl_static_inline='static'
phostname='hostname'
pidtype=int
-privlib='/usr/local/lib/perl5/5.20'
-privlibexp='/usr/local/lib/perl5/5.20'
+privlib='/usr/local/lib/perl5/5.21'
+privlibexp='/usr/local/lib/perl5/5.21'
procselfexe=''
prototype='undef'
ptrsize='4'
sig_num_init='0'
sig_size='1'
signal_t=int
-sitearch='/usr/local/lib/perl5/5.20/unknown'
-sitearchexp='/usr/local/lib/perl5/5.20/unknown'
-sitelib='/usr/local/lib/perl5/5.20'
+sitearch='/usr/local/lib/perl5/5.21/unknown'
+sitearchexp='/usr/local/lib/perl5/5.21/unknown'
+sitelib='/usr/local/lib/perl5/5.21'
sitelib_stem='/usr/local/lib/perl5'
-sitelibexp='/usr/local/lib/perl5/5.20'
+sitelibexp='/usr/local/lib/perl5/5.21'
sizesize=4
sizetype='size_t'
socksizetype='int'
alignbytes='8'
ansi2knr=''
aphostname='/bin/hostname'
-archlib='/usr/local/lib/perl5/5.20/unknown'
-archlibexp='/usr/local/lib/perl5/5.20/unknown'
+archlib='/usr/local/lib/perl5/5.21/unknown'
+archlibexp='/usr/local/lib/perl5/5.21/unknown'
archname='unknown64'
asctime_r_proto='0'
bin='/usr/local/bin'
perl_static_inline='static'
phostname='hostname'
pidtype=int
-privlib='/usr/local/lib/perl5/5.20'
-privlibexp='/usr/local/lib/perl5/5.20'
+privlib='/usr/local/lib/perl5/5.21'
+privlibexp='/usr/local/lib/perl5/5.21'
procselfexe=''
prototype='undef'
ptrsize='8'
sig_num_init='0'
sig_size='1'
signal_t=int
-sitearch='/usr/local/lib/perl5/5.20/unknown'
-sitearchexp='/usr/local/lib/perl5/5.20/unknown'
-sitelib='/usr/local/lib/perl5/5.20'
+sitearch='/usr/local/lib/perl5/5.21/unknown'
+sitearchexp='/usr/local/lib/perl5/5.21/unknown'
+sitelib='/usr/local/lib/perl5/5.21'
sitelib_stem='/usr/local/lib/perl5'
-sitelibexp='/usr/local/lib/perl5/5.20'
+sitelibexp='/usr/local/lib/perl5/5.21'
sizesize=4
sizetype='size_t'
socksizetype='int'
dVAR;
static const char file[] = __FILE__;
const struct xsub_details *xsub = details;
- const struct xsub_details *end = C_ARRAY_END(details);
+ const struct xsub_details *end
+ = details + sizeof(details) / sizeof(details[0]);
do {
newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
SV*
Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
{
-
- /*NOTE NOTE NOTE - If you want to use "return" in this routine you MUST
- * use the following define */
-
-#define CORE_SWASH_INIT_RETURN(x) \
- PL_curpm= old_PL_curpm; \
- return x
-
/* Initialize and return a swash, creating it if necessary. It does this
* by calling utf8_heavy.pl in the general case. The returned value may be
* the swash's inversion list instead if the input parameters allow it.
* <invlist> is only valid for binary properties */
dVAR;
- PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */
-
SV* retval = &PL_sv_undef;
HV* swash_hv = NULL;
const int invlist_swash_boundary =
assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
assert(! invlist || minbits == 1);
- PL_curpm= NULL; /* reset PL_curpm so that we dont get confused between the regex
- that triggered the swash init and the swash init perl logic itself.
- See perl #122747 */
-
/* If data was passed in to go out to utf8_heavy to find the swash of, do
* so */
if (listsv != &PL_sv_undef || strNE(name, "")) {
/* If caller wants to handle missing properties, let them */
if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
- CORE_SWASH_INIT_RETURN(NULL);
+ return NULL;
}
Perl_croak(aTHX_
"Can't find Unicode property definition \"%"SVf"\"",
}
}
- CORE_SWASH_INIT_RETURN(retval);
-#undef CORE_SWASH_INIT_RETURN
+ return retval;
}
HV *const hv = MUTABLE_HV(SvRV(swash));
U32 klen;
U32 off;
- STRLEN slen = 0;
+ STRLEN slen;
STRLEN needents;
const U8 *tmps = NULL;
U32 bit;
Perl's version of C<strdup()>. Returns a pointer to a newly allocated
string which is a duplicate of C<pv>. The size of the string is
-determined by C<strlen()>, which means it may not contain embedded C<NUL>
-characters and must have a trailing C<NUL>. The memory allocated for the new
-string can be freed with the C<Safefree()> function.
+determined by C<strlen()>. The memory allocated for the new string can
+be freed with the C<Safefree()> function.
On some platforms, Windows for example, all allocated memory owned by a thread
is deallocated when that thread ends. So if you need that not to happen, you
Perl's version of what C<strndup()> would be if it existed. Returns a
pointer to a newly allocated string which is a duplicate of the first
C<len> bytes from C<pv>, plus a trailing
-C<NUL> byte. The memory allocated for
+NUL byte. The memory allocated for
the new string can be freed with the C<Safefree()> function.
On some platforms, Windows for example, all allocated memory owned by a thread
Perl_croak_no_mem(void)
{
dTHX;
+ int rc;
+
/* Can't use PerlIO to write as it allocates memory */
- PERL_UNUSED_RESULT(PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, sizeof(PL_no_mem)-1));
+ rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, sizeof(PL_no_mem)-1);
+ /* silently ignore failures */
+ PERL_UNUSED_VAR(rc);
my_exit(1);
}
{
dVAR;
PERL_ARGS_ASSERT_VWARNER;
- if (
- (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
- !(PL_in_eval & EVAL_KEEPERR)
- ) {
+ if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
SV * const msv = vmess(pat, args);
invoke_exception_hook(msv, FALSE);
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
- /* This next branch should only be called #if defined(HAS_SETENV), but
- Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
- were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
- */
-# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV))
+# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
PERL_UNUSED_CONTEXT;
return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
- ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
+ ? NULL : PL_magic_vtables + vtbl_id;
}
I32
{
struct perl_vars *plvarsp = NULL;
# ifdef PERL_GLOBAL_STRUCT
- const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
- const IV ncheck = C_ARRAY_LENGTH(Gcheck);
+ const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
+ const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
/* PerlMem_malloc() because can't use even safesysmalloc() this early. */
plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
# else
retval = vsprintf(buffer, format, apc);
# endif
- va_end(apc);
#else
# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
=for apidoc my_strlcat
The C library C<strlcat> if available, or a Perl implementation of it.
-This operates on C C<NUL>-terminated strings.
+This operates on C NUL-terminated strings.
C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
-most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate,
+most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
practice this should not happen as it means that either C<size> is incorrect or
-that C<dst> is not a proper C<NUL>-terminated string).
+that C<dst> is not a proper NUL-terminated string).
Note that C<size> is the full size of the destination buffer and
-the result is guaranteed to be C<NUL>-terminated if there is room. Note that
-room for the C<NUL> should be included in C<size>.
+the result is guaranteed to be NUL-terminated if there is room. Note that room
+for the NUL should be included in C<size>.
=cut
=for apidoc my_strlcpy
The C library C<strlcpy> if available, or a Perl implementation of it.
-This operates on C C<NUL>-terminated strings.
+This operates on C NUL-terminated strings.
C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
-to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
+to C<dst>, NUL-terminating the result if C<size> is not 0.
=cut
if (!PERLDB_SUB_NN) {
GV *gv = CvGV(cv);
- if (gv && !svp) {
+ if (!svp) {
gv_efullname3(dbsv, gv, NULL);
}
- else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || !gv
+ else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
|| ( /* Could be imported, and old sub redefined. */
(GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
cpan/Pod-Parser/blib/script/podselect
utils/c2ph # link = utils/pstruct
utils/cpan
-utils/config_data
utils/corelist
utils/enc2xs
utils/h2ph
# Files to be built with variable substitution after miniperl is
# available. Dependencies handled manually below (for now).
-pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL json_pp.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL ptargrep.PL shasum.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL pod2html.PL zipdetails.PL
-plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh json_pp perlbug perldoc perlivp pl2pm prove ptar ptardiff ptargrep shasum splain libnetcfg piconv enc2xs xsubpp pod2html zipdetails
-plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./json_pp ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./ptargrep ./shasum ./splain ./libnetcfg ./piconv ./enc2xs ./xsubpp ./pod2html ./zipdetails
+pl = c2ph.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL json_pp.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL ptargrep.PL shasum.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL pod2html.PL zipdetails.PL
+plextract = c2ph corelist cpan h2ph h2xs instmodsh json_pp perlbug perldoc perlivp pl2pm prove ptar ptardiff ptargrep shasum splain libnetcfg piconv enc2xs xsubpp pod2html zipdetails
+plextractexe = ./c2ph ./corelist ./cpan ./h2ph ./h2xs ./json_pp ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./ptargrep ./shasum ./splain ./libnetcfg ./piconv ./enc2xs ./xsubpp ./pod2html ./zipdetails
all: $(plextract)
cpan: cpan.PL ../config.sh
-config_data: config_data.PL ../config.sh
-
corelist: corelist.PL ../config.sh
h2ph: h2ph.PL ../config.sh
+++ /dev/null
-#!/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.
-my $origdir = cwd;
-chdir dirname($0);
-my $file = basename($0, '.PL');
-$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 $Config{perlpath} -S \$0 \${1+"\$@"}'
- if \$running_under_some_shell;
-!GROK!THIS!
-
-use File::Spec;
-
-my $script = File::Spec->catfile(
- File::Spec->catdir(
- File::Spec->updir, qw[cpan Module-Build bin]
- ), "config_data");
-
-if (open(IN, $script)) {
- print OUT <IN>;
- close IN;
-} else {
- die "$0: cannot find '$script'\n";
-}
-
-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;
sub build_preamble_if_necessary
{
# Increment $VERSION every time this function is modified:
- my $VERSION = 4;
+ my $VERSION = 3;
my $preamble = "$Dest_dir/_h2ph_pre.ph";
# Can we skip building the preamble file?
open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
print PREAMBLE "# This file was created by h2ph version $VERSION\n";
- # Prevent non-portable hex constants from warning.
- #
- # We still produce an overflow warning if we can't represent
- # a hex constant as an integer.
- print PREAMBLE "no warnings qw(portable);\n";
foreach (sort keys %define) {
if ($opt_D) {
# integer:
print PREAMBLE
"unless (defined &$_) { sub $_() { $1 } }\n\n";
- } elsif ($define{$_} =~ /^([+-]?0x[\da-f]+)U?L{0,2}$/i) {
- # hex integer
- # Special cased, since perl warns on hex integers
- # that can't be represented in a UV.
- #
- # This way we get the warning at time of use, so the user
- # only gets the warning if they happen to use this
- # platform-specific definition.
- my $code = $1;
- $code = "hex('$code')" if length $code > 10;
- print PREAMBLE
- "unless (defined &$_) { sub $_() { $code } }\n\n";
} elsif ($define{$_} =~ /^\w+$/) {
my $def = $define{$_};
if ($isatype{$def}) {
utils2 = [.utils]h2xs.com [.utils]libnetcfg.com [.lib]perlbug.com [.utils]json_pp.com
utils3 = [.utils]perlivp.com [.lib]splain.com [.utils]pl2pm.com [.utils]xsubpp.com [.utils]pod2html.com [.utils]instmodsh.com
utils4 = [.utils]enc2xs.com [.utils]piconv.com [.utils]cpan.com [.utils]prove.com [.utils]ptar.com [.utils]ptardiff.com [.utils]shasum.com
-utils5 = [.utils]corelist.com [.utils]config_data.com [.utils]ptargrep.com [.utils]zipdetails.com
+utils5 = [.utils]corelist.com [.utils]ptargrep.com [.utils]zipdetails.com
.ifdef NOX2P
all : base extras archcorefiles preplibrary [.pod]perltoc.pod
extra.pods : miniperl
@ @extra_pods.com
-PERLDELTA_CURRENT = [.pod]perl5203delta.pod
+PERLDELTA_CURRENT = [.pod]perl5210delta.pod
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
[.utils]shasum.com : [.utils]shasum.PL $(ARCHDIR)Config.pm
$(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
-[.utils]config_data.com : [.utils]config_data.PL $(ARCHDIR)Config.pm
- $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
-
[.utils]corelist.com : [.utils]corelist.PL $(ARCHDIR)Config.pm
$(MINIPERL) -"I[-.lib]" $(MMS$SOURCE)
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
av$(O) : av.c $(h)
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
-caretx$(O) : caretx.c $(h)
- $(CC) $(CORECFLAGS) $(MMS$SOURCE)
deb$(O) : deb.c $(h)
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
doio$(O) : doio.c $(h)
*/
if (value > 0) {
status = simple_trnlnm(name, val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
return 0;
/* Allow an exception to bring Perl into the VMS debugger */
vms_debug_on_exception = 0;
status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_on_exception = 1;
/* Debug unix/vms file translation routines */
vms_debug_fileify = 0;
status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_fileify = 1;
/* enable it so that the impact can be studied. */
vms_bug_stat_filename = 0;
status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_bug_stat_filename = 1;
/* Create VTF-7 filenames from Unicode instead of UTF-8 */
vms_vtf7_filenames = 0;
status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_vtf7_filenames = 1;
/* unlink all versions on unlink() or rename() */
vms_unlink_all_versions = 0;
- status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
- if (status) {
+ status = simple_trnlnm
+ ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_unlink_all_versions = 1;
/* Detect running under GNV Bash or other UNIX like shell */
gnv_unix_shell = 0;
status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
gnv_unix_shell = 1;
set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
/* PCP mode requires creating /dev/null special device file */
decc_bug_devnull = 0;
status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
decc_bug_devnull = 1;
#else
status = simple_trnlnm
("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_disable_to_vms_logname_translation = 1;
#ifndef __VAX
status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_efs_case_preserve = 1;
#endif
status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_filename_unix_report = 1;
}
}
status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_filename_unix_only = 1;
}
}
status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_filename_unix_no_version = 1;
}
}
status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
- if (status) {
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
decc_readdir_dropdotnotype = 1;
/* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
/* for strict backward compatibility */
- status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
- if (status) {
+ status = simple_trnlnm
+ ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
+ if ($VMS_STATUS_SUCCESS(status)) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_posix_exit = 1;
char tbuf[64];
SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
char *buf;
-#ifdef USE_LOCALE_NUMERIC
- const char * const cur_numeric = setlocale(LC_NUMERIC, NULL);
- assert(cur_numeric);
-
- /* XS code can set the locale without us knowing. To protect the
- * version number parsing, which requires the radix character to be a
- * dot, update our records as to what the locale is, so that our
- * existing macro mechanism can correctly change it to a dot and back
- * if necessary. This code is extremely unlikely to be in a loop, so
- * the extra work will have a negligible performance impact. See [perl
- * #121930].
- *
- * If the current locale is a standard one, but we are expecting it to
- * be a different, underlying locale, update our records to make the
- * underlying locale this (standard) one. If the current locale is not
- * a standard one, we should be expecting a non-standard one, the same
- * one that we have recorded as the underlying locale. If not, update
- * our records. */
- if (strEQ(cur_numeric, "C") || strEQ(cur_numeric, "POSIX")) {
- if (! PL_numeric_standard) {
- new_numeric(cur_numeric);
- }
- }
- else if (PL_numeric_standard
- || ! PL_numeric_name
- || strNE(PL_numeric_name, cur_numeric))
- {
- new_numeric(cur_numeric);
- }
-#endif
- { /* Braces needed because macro just below declares a variable */
STORE_NUMERIC_LOCAL_SET_STANDARD();
if (sv) {
Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
buf = tbuf;
}
RESTORE_NUMERIC_LOCAL();
- }
while (buf[len-1] == '0' && len > 0) len--;
if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
version = savepvn(buf, len);
# Windows SDK 64-bit compiler and tools
#
# This is set up to build a perl.exe that runs off a shared library
-# (perl520.dll). Also makes individual DLLs for the XS extensions.
+# (perl521.dll). Also makes individual DLLs for the XS extensions.
#
##
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER = \5.20.3
+#INST_VER = \5.21.0
#
# Comment this out if you DON'T want your perl installation to have
# set this to additionally provide a statically linked perl-static.exe.
# Note that dynamic loading will not work with this perl, so you must
# include required modules statically using the STATIC_EXT or ALL_STATIC
-# variables below. A static library perl520s.lib will also be created.
+# variables below. A static library perl521s.lib will also be created.
# Ordinary perl.exe is not affected by this option.
#
#BUILD_STATIC = define
# makedef.pl must be updated if this changes, and this should normally
# only change when there is an incompatible revision of the public API.
-PERLIMPLIB = ..\perl520.lib
-PERLSTATICLIB = ..\perl520s.lib
-PERLDLL = ..\perl520.dll
+PERLIMPLIB = ..\perl521.lib
+PERLSTATICLIB = ..\perl521s.lib
+PERLDLL = ..\perl521.dll
MINIPERL = ..\miniperl.exe
MINIDIR = .\mini
..\utils\libnetcfg \
..\utils\enc2xs \
..\utils\piconv \
- ..\utils\config_data \
..\utils\corelist \
..\utils\cpan \
..\utils\xsubpp \
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5203delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5210delta.pod
cd ..\win32
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
-if exist $(LIBDIR)\Attribute rmdir /s /q $(LIBDIR)\Attribute
-if exist $(LIBDIR)\autodie rmdir /s /q $(LIBDIR)\autodie
-if exist $(LIBDIR)\Carp rmdir /s /q $(LIBDIR)\Carp
- -if exist $(LIBDIR)\CGI rmdir /s /q $(LIBDIR)\CGI
-if exist $(LIBDIR)\Compress rmdir /s /q $(LIBDIR)\Compress
-if exist $(LIBDIR)\Config\Perl rmdir /s /q $(LIBDIR)\Config\Perl
-if exist $(LIBDIR)\CPAN rmdir /s /q $(LIBDIR)\CPAN
-if exist $(LIBDIR)\Hash rmdir /s /q $(LIBDIR)\Hash
-if exist $(LIBDIR)\HTTP rmdir /s /q $(LIBDIR)\HTTP
-if exist $(LIBDIR)\I18N rmdir /s /q $(LIBDIR)\I18N
- -if exist $(LIBDIR)\inc rmdir /s /q $(LIBDIR)\inc
-if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO
-if exist $(LIBDIR)\IPC rmdir /s /q $(LIBDIR)\IPC
-if exist $(LIBDIR)\JSON rmdir /s /q $(LIBDIR)\JSON
-if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME
-if exist $(LIBDIR)\Module rmdir /s /q $(LIBDIR)\Module
-if exist $(LIBDIR)\Net\FTP rmdir /s /q $(LIBDIR)\Net\FTP
- -if exist $(LIBDIR)\Package rmdir /s /q $(LIBDIR)\Package
-if exist $(LIBDIR)\Params rmdir /s /q $(LIBDIR)\Params
-if exist $(LIBDIR)\Parse rmdir /s /q $(LIBDIR)\Parse
-if exist $(LIBDIR)\Perl rmdir /s /q $(LIBDIR)\Perl
-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 \
- perl5203delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5210delta.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 \
perlwin32.pod
-cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \
perldoc perlivp libnetcfg enc2xs piconv cpan *.bat \
- xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep shasum corelist config_data zipdetails
+ xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep shasum corelist zipdetails
-cd ..\x2p && del /f find2perl s2p psed *.bat
-del /f ..\config.sh perlmain.c dlutils.c config.h.new \
perlmainst.c
#
SRCDIR = ..
-PV = 520
+PV = 521
# INSTALL_ROOT specifies a path where this perl will be installed on CE device
INSTALL_ROOT=/netzwerk/sprache/perl
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
-d_locconv='undef'
+d_locconv='define'
d_lockf='undef'
d_longdbl='undef'
d_longlong='undef'
i_langinfo='undef'
i_libutil='undef'
i_limits='define'
-i_locale='define'
+i_locale='undef'
i_machcthr='undef'
i_malloc='define'
i_mallocmalloc='undef'
* This symbol, if defined, indicates that the localeconv routine is
* available for numeric and monetary formatting conventions.
*/
-/*#define HAS_LOCALECONV /**/
+#define HAS_LOCALECONV /**/
/* HAS_LOCKF:
* This symbol, if defined, indicates that the lockf routine is
* available to exclusively create and open a uniquely named
* temporary file.
*/
-#if __MINGW64_VERSION_MAJOR >= 4
-#define HAS_MKSTEMP
-#endif
+/*#define HAS_MKSTEMP / **/
/* HAS_MMAP:
* This symbol, if defined, indicates that the mmap system call is
}
elsif ($opt{cc} =~ /\bgcc\b/) {
$int64 = 'long long';
- $int64f = 'I64';
+ $int64f = 'll';
}
# set large files options
# Windows SDK 64-bit compiler and tools
#
# This is set up to build a perl.exe that runs off a shared library
-# (perl520.dll). Also makes individual DLLs for the XS extensions.
+# (perl521.dll). Also makes individual DLLs for the XS extensions.
#
##
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER *= \5.20.3
+#INST_VER *= \5.21.0
#
# Comment this out if you DON'T want your perl installation to have
# set this to additionally provide a statically linked perl-static.exe.
# Note that dynamic loading will not work with this perl, so you must
# include required modules statically using the STATIC_EXT or ALL_STATIC
-# variables below. A static library perl520s.lib will also be created.
+# variables below. A static library perl521s.lib will also be created.
# Ordinary perl.exe is not affected by this option.
#
#BUILD_STATIC *= define
LIBOUT_FLAG =
BUILDOPT += -fno-strict-aliasing -mms-bitfields
-MINIBUILDOPT += -fno-strict-aliasing
.ELSE
..\utils\libnetcfg \
..\utils\enc2xs \
..\utils\piconv \
- ..\utils\config_data \
..\utils\corelist \
..\utils\cpan \
..\utils\xsubpp \
CFGSH_TMPL = config.gc
CFGH_TMPL = config_H.gc
-PERLIMPLIB = ..\libperl520$(a)
-PERLSTATICLIB = ..\libperl520s$(a)
+PERLIMPLIB = ..\libperl521$(a)
+PERLSTATICLIB = ..\libperl521s$(a)
INT64 = long long
INT64f = ll
# makedef.pl must be updated if this changes, and this should normally
# only change when there is an incompatible revision of the public API.
-PERLIMPLIB *= ..\perl520$(a)
-PERLSTATICLIB *= ..\perl520s$(a)
-PERLDLL = ..\perl520.dll
+PERLIMPLIB *= ..\perl521$(a)
+PERLSTATICLIB *= ..\perl521s$(a)
+PERLDLL = ..\perl521.dll
XCOPY = xcopy /f /r /i /d /y
RCOPY = xcopy /f /r /i /e /d /y
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5203delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5210delta.pod
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Attribute rmdir /s /q $(LIBDIR)\Attribute
-if exist $(LIBDIR)\autodie rmdir /s /q $(LIBDIR)\autodie
-if exist $(LIBDIR)\Carp rmdir /s /q $(LIBDIR)\Carp
- -if exist $(LIBDIR)\CGI rmdir /s /q $(LIBDIR)\CGI
-if exist $(LIBDIR)\Compress rmdir /s /q $(LIBDIR)\Compress
-if exist $(LIBDIR)\Config\Perl rmdir /s /q $(LIBDIR)\Config\Perl
-if exist $(LIBDIR)\CPAN rmdir /s /q $(LIBDIR)\CPAN
-if exist $(LIBDIR)\Hash rmdir /s /q $(LIBDIR)\Hash
-if exist $(LIBDIR)\HTTP rmdir /s /q $(LIBDIR)\HTTP
-if exist $(LIBDIR)\I18N rmdir /s /q $(LIBDIR)\I18N
- -if exist $(LIBDIR)\inc rmdir /s /q $(LIBDIR)\inc
-if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO
-if exist $(LIBDIR)\IPC rmdir /s /q $(LIBDIR)\IPC
-if exist $(LIBDIR)\JSON rmdir /s /q $(LIBDIR)\JSON
-if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME
-if exist $(LIBDIR)\Module rmdir /s /q $(LIBDIR)\Module
-if exist $(LIBDIR)\Net\FTP rmdir /s /q $(LIBDIR)\Net\FTP
- -if exist $(LIBDIR)\Package rmdir /s /q $(LIBDIR)\Package
-if exist $(LIBDIR)\Params rmdir /s /q $(LIBDIR)\Params
-if exist $(LIBDIR)\Parse rmdir /s /q $(LIBDIR)\Parse
-if exist $(LIBDIR)\Perl rmdir /s /q $(LIBDIR)\Perl
-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 \
- perl5203delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5210delta.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 \
perlwin32.pod
-cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \
perldoc perlivp libnetcfg enc2xs piconv cpan *.bat \
- xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep shasum corelist config_data zipdetails
+ xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep shasum corelist zipdetails
-cd ..\x2p && del /f find2perl s2p psed *.bat
-del /f ..\config.sh perlmain.c dlutils.c config.h.new \
perlmainst.c
perl5180delta.pod \
perl5181delta.pod \
perl5182delta.pod \
- perl5184delta.pod \
perl5200delta.pod \
- perl5201delta.pod \
- perl5202delta.pod \
- perl5203delta.pod \
+ perl5210delta.pod \
perl561delta.pod \
perl56delta.pod \
perl581delta.pod \
perltoot.pod \
perltrap.pod \
perlunicode.pod \
- perlunicook.pod \
perlunifaq.pod \
perluniintro.pod \
perluniprops.pod \
perl5180delta.man \
perl5181delta.man \
perl5182delta.man \
- perl5184delta.man \
perl5200delta.man \
- perl5201delta.man \
- perl5202delta.man \
- perl5203delta.man \
+ perl5210delta.man \
perl561delta.man \
perl56delta.man \
perl581delta.man \
perltoot.man \
perltrap.man \
perlunicode.man \
- perlunicook.man \
perlunifaq.man \
perluniintro.man \
perluniprops.man \
perl5180delta.html \
perl5181delta.html \
perl5182delta.html \
- perl5184delta.html \
perl5200delta.html \
- perl5201delta.html \
- perl5202delta.html \
- perl5203delta.html \
+ perl5210delta.html \
perl561delta.html \
perl56delta.html \
perl581delta.html \
perltoot.html \
perltrap.html \
perlunicode.html \
- perlunicook.html \
perlunifaq.html \
perluniintro.html \
perluniprops.html \
perl5180delta.tex \
perl5181delta.tex \
perl5182delta.tex \
- perl5184delta.tex \
perl5200delta.tex \
- perl5201delta.tex \
- perl5202delta.tex \
- perl5203delta.tex \
+ perl5210delta.tex \
perl561delta.tex \
perl56delta.tex \
perl581delta.tex \
perltoot.tex \
perltrap.tex \
perlunicode.tex \
- perlunicook.tex \
perlunifaq.tex \
perluniintro.tex \
perluniprops.tex \
* XXX this needs strengthening (for PerlIO)
* -- BKS, 11-11-200
*/
-#if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4
int mkstemp(const char *path)
{
dTHX;
goto retry;
return fd;
}
-#endif
static long
find_pid(pTHX_ int pid)
#define snprintf _snprintf
#define vsnprintf _vsnprintf
+#ifdef USING_MSVC6
+/* VC6 has broken NaN semantics: NaN == NaN returns true instead of false */
+#define NAN_COMPARE_BROKEN 1
+#endif
+
/* on VC2003, msvcrt.lib is missing these symbols */
#if _MSC_VER >= 1300 && _MSC_VER < 1400
# pragma intrinsic(_rotl64,_rotr64)
#endif
extern char * getlogin(void);
extern int chown(const char *p, uid_t o, gid_t g);
-#if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4
extern int mkstemp(const char *path);
#endif
-#endif
#undef Stat
#define Stat win32_stat
#ifdef MYMALLOC
#define EMBEDMYMALLOC /**/
-/* #define USE_PERL_SBRK / **/
-/* #define PERL_SBRK_VIA_MALLOC / **/
+/* #define USE_PERL_SBRK /**/
+/* #define PERL_SBRK_VIA_MALLOC /**/
#endif
#ifdef PERL_TEXTMODE_SCRIPTS
projects / platform / upstream / perl.git / commitdiff