Adrian M. Enache <enache@rdslink.ro>
Adriano Ferreira <a.r.ferreira@gmail.com>
Akim Demaille <akim@epita.fr>
+Alain Barbet <alian@cpan.org>
Alan Burlison <Alan.Burlison@uk.sun.com>
Alan Champion <achampio@lehman.com>
+Alan Ferrency <alan@pair.com>
Alan Grover <awgrover@gmail.com>
Alan Grow <agrow@thegotonerd.com>
Alan Haggai Alavi <haggai@cpan.org>
Alan Harder <Alan.Harder@Ebay.Sun.COM>
Alan Hourihane <alanh@fairlite.co.uk>
Alan Modra
-Alan Ferrency <alan@pair.com>
Alastair Douglas <alastair.douglas@gmail.com>
Albert Chin-A-Young <china@thewrittenword.com>
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>
-Alexei Alexandrov <alexei.alexandrov@gmail.com>
Alex Davies <adavies@ptc.com>
Alex Gough <alex@rcon.org>
Alex Solovey <a.solovey@gmail.com>
Alex Vandiver <alexmv@mit.edu>
Alex Waugh <alex@alexwaugh.com>
+Alexander Alekseev <alex@alemate.ru>
Alexander Bluhm <alexander_bluhm@genua.de>
-Alexander D'Archangel <darksuji@gmail.com>
+Alexander D'Archangel <darksuji@gmail.com>
Alexander Gernler <alexander_gernler@genua.de>
Alexander Gough <alex-p5p@earth.li>
+Alexander Hartmaier <abraxxa@cpan.org>
Alexander Klimov <ask@wisdom.weizmann.ac.il>
Alexander Smishlajev <als@turnhere.com>
+Alexander Voronov <alexander-voronov@yandex.ru>
Alexandr Ciornii <alexchorny@gmail.com>
+Alexandre (Midnite) Jousset <mid@gtmp.org>
+Alexei Alexandrov <alexei.alexandrov@gmail.com>
Alexey Mahotkin <alexm@netli.com>
Alexey Toptygin <alexeyt@freeshell.org>
Alexey Tourbin <at@altlinux.ru>
Alexey V. Barantsev <barancev@kazbek.ispras.ru>
Ali Polatel <alip@exherbo.org>
Allen Smith <allens@cpan.org>
-Alain Barbet <alian@cpan.org>
Ambrose Kofi Laing
Ammon Riley <ammon@rhythm.com>
Ananth Kesari <HYanantha@novell.com>
Bram <perl-rt@wizbit.be>
Brendan Byrd <BBYRD@CPAN.org>
Brendan O'Dea <bod@debian.org>
-Brent B. Powers <powers@ml.com>
Breno G. de Oliveira <garu@cpan.org>
+Brent B. Powers <powers@ml.com>
Brent Dax <brentdax@cpan.org>
Brooks D Boyd
Brian Callaghan <callagh@itginc.com>
Calle Dybedahl <calle@lysator.liu.se>
Campo Weijerman <rfc822@nl.ibm.com>
Carl Eklof <CEklof@endeca.com>
-Carl M. Fongheiser <cmf@ins.infonet.net>
Carl Hayter <hayter@usc.edu>
+Carl M. Fongheiser <cmf@ins.infonet.net>
Carl Witty <cwitty@newtonlabs.com>
Cary D. Renzema <caryr@mxim.com>
Casey R. Tweten <crt@kiski.net>
Chris Lightfoot <chris@ex-parrot.com>
Chris Nandor <pudge@pobox.com>
Chris Pepper
+Chris R. Donnelly <chris.donnelly@vauto.com>
+Chris Travers <chris.travers@gmail.com>
Chris Tubutis <chris@broadband.att.com>
Chris Wick <cwick@lmc.com>
Chris Williams <chrisw@netinfo.com.au>
chromatic <chromatic@wgz.org>
Chuck Phillips <perl@cadop.com>
Chunhui Teng <cteng@nortel.ca>
-Clark Cooper <coopercc@netheaven.com>
Claes Jacobsson <claes@surfar.nu>
+Clark Cooper <coopercc@netheaven.com>
Claudio Ramirez <nxadm@cpan.org>
Clinton A. Pierce <clintp@geeksalad.org>
Colin Kuskie <ckuskie@cadence.com>
Craig A. Berry <craigberry@mac.com>
Craig DeForest <zowie@euterpe.boulder.swri.edu>
Craig Milo Rogers <Rogers@ISI.EDU>
-Curtis Poe <cp@onsitetech.com>
Curtis Jewell <perl@csjewell.fastmail.us>
+Curtis Poe <cp@onsitetech.com>
Dabrien 'Dabe' Murphy <dabe@dabe.com>
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
Dale Amon <amon@vnl.com>
David Kerry <davidk@tor.securecomputing.com>
David Landgren <david@landgren.net>
David Leadbeater <dgl@dgl.cx>
-David McLean <davem@icc.gsfc.nasa.gov>
+David M. Syzdek <david@syzdek.net>
David Manura <dm.list@math2.org>
+David McLean <davem@icc.gsfc.nasa.gov>
David Mitchell <davem@iabyn.nospamdeletethisbit.com>
David Muir Sharnoff <muir@idiom.com>
David Nicol <whatever@davidnicol.com>
David Starks-Browning <dstarks@rc.tudelft.nl>
David Steinbrunner <dsteinbrunner@pobox.com>
David Sundstrom <sunds@asictest.sc.ti.com>
-David M. Syzdek <david@syzdek.net>
David Wheeler <david@justatheory.com>
Davin Milun <milun@cs.Buffalo.EDU>
Dean Roehrich <roehrich@cray.com>
Elaine -HFB- Ashton <elaine@chaos.wustl.edu>
Elizabeth Mattijsen <liz@dijkmat.nl>
Enrico Sorcinelli <bepi@perl.it>
-Eric Arnold <eric.arnold@sun.com>
Eric Amick
+Eric Arnold <eric.arnold@sun.com>
Eric Bartley <bartley@icd.cc.purdue.edu>
Eric Brine <ikegami@adaelis.com>
Eric E. Coe <Eric.Coe@oracle.com>
Fingle Nark <finglenark@gmail.com>
Florent Guillaume
Florian Ragwitz <rafl@debian.org>
+François Désarménien <desar@club-internet.fr>
François Perrad <francois.perrad@gadz.org>
Frank Crawford
Frank Ridderbusch <Frank.Ridderbusch@pdb.siemens.de>
Frank Wiegand <frank.wiegand@gmail.com>
Franklin Chen <chen@adi.com>
Franz Fasching <perldev@drfasching.com>
-François Désarménien <desar@club-internet.fr>
Frederic Briere <fbriere@fbriere.net>
Fréderic Chauveau <fmc@pasteur.fr>
Fyodor Krasnov <fyodor@aha.ru>
Gary Ng <71564.1743@compuserve.com>
Gavin Shelley <columbusmonkey@me.com>
Gene Sullivan <genesullivan50@yahoo.com>
-Geoffrey T. Dairiki <dairiki@dairiki.org>
Geoffrey F. Green <geoff-public@stuebegreen.com>
+Geoffrey T. Dairiki <dairiki@dairiki.org>
Georg Schwarz <geos@epost.de>
George Greer <perl@greerga.m-l.org>
George Necula <necula@eecs.berkeley.edu>
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>
+Gordon Lack <gml4410@ggr.co.uk>
Goro Fuji <gfuji@cpan.org>
Grace Lee <grace@hal.com>
Graham Barr <gbarr@pobox.com>
Jake Hamby <jehamby@lightside.com>
James <james@rf.net>
James A. Duncan <jduncan@fotango.com>
+James E Keenan <jkeenan@cpan.org>
James FitzGibbon <james@ican.net>
James Jurach <muaddib@erf.net>
-James E Keenan <jkeenan@cpan.org>
James Mastros <james@mastros.biz>
-James McCoy <vega.james@gmail.com>
+James McCoy <vega.james@gmail.com>
James Raspass <jraspass@gmail.com>
Jamshid Afshar
Jan D. <jan.djarv@mbox200.swipnet.se>
Lincoln D. Stein <lstein@cshl.org>
Lionel Cons <lionel.cons@cern.ch>
Louis Strous <louis.strous@gmail.com>
+Lubomir Rintel <lkundrak@v3.sk>
Luc St-Louis <luc.st-louis@ca.transport.bombardier.com>
Luca Fini
Lucas Holt <luke@foolishgames.com>
Lukas Mai <l.mai@web.de>
Luke Closs <lukec@cpan.org>
Luke Ross <lukeross@gmail.com>
-Lubomir Rintel <lkundrak@v3.sk>
Lupe Christoph <lupe@lupe-christoph.de>
Luther Huffman <lutherh@stratcom.com>
Maik Hentsche <maik@mm-double.de>
Marcel Grünauer <marcel@codewerk.com>
Marco Peereboom <marco@conformal.com>
Marcus Holland-Moritz <mhx-perl@gmx.net>
-Markus Jansen <Markus.Jansen@ericsson.com>
Marek Rouchal <marek.rouchal@infineon.com>
Mark A Biggar <mab@wdl.loral.com>
Mark A. Hershberger <mah@everybody.org>
Mark Bixby <mark@bixby.org>
Mark Dickinson <dickins3@fas.harvard.edu>
Mark Dootson <mdootson@cpan.org>
-Mark Leighton Fisher <markleightonfisher@gmail.com>
Mark Fowler <mark@twoshortplanks.com>
Mark Hanson
Mark J. Reed <mreed@strange.turner.com>
Mark Klein <mklein@dis.com>
Mark Knutsen <knutsen@pilot.njin.net>
Mark Kvale <kvale@phy.ucsf.edu>
-Mark Leighton Fisher <mark-fisher@mindspring.com>
+Mark Leighton Fisher <markleightonfisher@gmail.com>
Mark Mielke <mark@mark.mielke.cc>
Mark Murray <mark@grondar.za>
Mark Overmeer <mark@overmeer.net>
Mark R. Levinson <mrl@isc.upenn.edu>
Mark Stosberg <mark@summersault.com>
Marko Asplund <aspa@merlot.kronodoc.fi>
+Markus Jansen <Markus.Jansen@ericsson.com>
Marnix van Ammers <marnix@gmail.com>
Martien Verbruggen <mgjv@comdyn.com.au>
Martijn Koster <mak@excitecorp.com>
Matt Johnson <matt.w.johnson@gmail.com>
Matt Kimball
Matt Kraai <kraai@ftbfs.org>
+Matt S Trout <mst@shadowcat.co.uk>
Matt Sergeant <matt@sergeant.org>
Matt Taggart <taggart@debian.org>
-Matt S Trout <mst@shadowcat.co.uk>
Matthew Black <black@csulb.edu>
Matthew Green <mrg@splode.eterna.com.au>
Matthew Horsfall <wolfsage@gmail.com>
Michael Cook <mcook@cognex.com>
Michael Cummings <mcummings@gentoo.org>
Michael De La Rue <mikedlr@tardis.ed.ac.uk>
-Michael van Elst <mlelstv@serpens.de>
Michael Engel <engel@nms1.cc.huji.ac.il>
Michael Fig <michael@liveblockauctions.com>
Michael G Schwern <schwern@pobox.com>
Michael Schroeder <Michael.Schroeder@informatik.uni-erlangen.de>
Michael Somos <somos@grail.cba.csuohio.edu>
Michael Stevens <mstevens@etla.org>
+Michael van Elst <mlelstv@serpens.de>
Michael Witten <mfwitten@gmail.com>
Michele Sardo
Mik Firestone <fireston@lexmark.com>
Milosz Tanski <mtanski@gridapp.com>
Milton L. Hankins <mlh@swl.msd.ray.com>
Misty De Meo <mistydemeo@github.com>
+Mohammed El-Afifi <mohammed_elafifi@yahoo.com>
Moritz Lenz <moritz@casella.verplant.org>
Moshe Kaminsky <kaminsky@math.huji.ac.il>
Mottaqui Karim <taqqui.karim@gmail.com>
Nick Gianniotis
Nick Ing-Simmons
Nick Johnston <nickjohnstonsky@gmail.com>
-Nick Logan <ugexe@cpan.org>
+Nick Logan <ugexe@cpan.org>
Nick Williams <Nick.Williams@morganstanley.com>
Nicolas Kaiser <nikai@nikai.net>
-Nicolas R. <atoomic@cpan.org>
+Nicolas R. <atoomic@cpan.org>
Niels Thykier <niels@thykier.net>
Nigel Sandever <njsandever@hotmail.com>
Niko Tyni <ntyni@debian.org>
Olaf Titz <olaf@bigred.inka.de>
Oleg Nesterov <oleg@redhat.com>
Olivier Blin <blino@mandriva.com>
-Olli Savia
-Ollivier Robert <roberto@keltia.freenix.fr>
Olivier Mengué <dolmen@cpan.org>
Olivier Thauvin <olivier.thauvin@aerov.jussieu.fr>
+Olli Savia
+Ollivier Robert <roberto@keltia.freenix.fr>
Osvaldo Villalon <ovillalon@dextratech.com>
Owain G. Ainsworth <oga@nicotinebsd.org>
Owen Taylor <owt1@cornell.edu>
-parv <parv@pair.com>
Papp Zoltan <padre@elte.hu>
+parv <parv@pair.com>
Pascal Rigaux <pixel@mandriva.com>
Patrick Donelan <pat@patspam.com>
Patrick Dugnolle <patrick.dugnolle@bnpparibas.com>
Pedro Felipe Horrillo Guerra <pancho@pancho.name>
Per Einar Ellefsen <per.einar@skynet.be>
Perlover <perlover@perlover.com>
-Peter BARABAS
Pete Peterson <petersonp@genrad.com>
+Peter BARABAS
Peter Chines <pchines@nhgri.nih.gov>
Peter Dintelmann <Peter.Dintelmann@Dresdner-Bank.com>
+Peter E. Yee <yee@trident.arc.nasa.gov>
Peter Gessner <peter.gessner@post.rwth-aachen.de>
Peter Gordon <peter@valor.com>
Peter Haworth <pmh@edison.ioppublishing.com>
Peter Valdemar Mørch <pm@capmon.dk>
Peter van Heusden <pvh@junior.uwc.ac.za>
Peter Wolfe <wolfe@teloseng.com>
-Peter E. Yee <yee@trident.arc.nasa.gov>
Petr Písař <ppisar@redhat.com>
Petter Reinholdtsen <pere@hungry.com>
Phil Lobbes <phil@perkpartners.com>
Richard Kandarian <richard.kandarian@lanl.gov>
Richard L. England <richard_england@mentorg.com>
Richard L. Maus, Jr. <rmaus@monmouth.com>
+Richard Levitte <levitte@openssl.org>
Richard Möhn <richard.moehn@fu-berlin.de>
Richard Ohnemus <richard_ohnemus@dallas.csd.sterling.com>
Richard Soderberg <p5-authors@crystalflame.net>
Rujith S. de Silva <desilva@netbox.com>
Ruslan Zakirov <ruz@bestpractical.com>
Russ Allbery <rra@stanford.edu>
+Russel O'Connor <roconnor@world.std.com>
Russell Fulton <russell@ccu1.auckland.ac.nz>
Russell Mosemann <mose@ccsn.edu>
-Russel O'Connor <roconnor@world.std.com>
Ryan Herbert <rherbert@sycamorehq.com>
Salvador Fandiño <sfandino@yahoo.com>
Salvador Ortiz Garcia <sog@msg.com.mx>
Sean M. Burke <sburke@cpan.org>
Sean Robinson <robinson_s@sc.maricopa.edu>
Sean Sheedy <seans@ncube.com>
+Sebastian Schmidt <yath@yath.de>
+Sebastian Steinlechner <steinlechner@gmx.net>
Sebastian Wittmeier <Sebastian.Wittmeier@ginko.de>
Sébastien Aperghis-Tramoni <saper@cpan.org>
Sebastien Barre <Sebastien.Barre@utc.fr>
-Sebastian Schmidt <yath@yath.de>
-Sebastian Steinlechner <steinlechner@gmx.net>
-Sérgio Durigan Júnior <sergiodj@linux.vnet.ibm.com>
Sergey Alekseev <varnie29a@mail.ru>
+Sergey Aleynikov <sergey.aleynikov@gmail.com>
+Sérgio Durigan Júnior <sergiodj@linux.vnet.ibm.com>
Shawn <svicalifornia@gmail.com>
Shawn M Moore <sartak@gmail.com>
Sherm Pendley <sherm@dot-app.org>
Steffen Müller <smueller@cpan.org>
Steffen Schwigon <ss5@renormalist.net>
Steffen Ullrich <coyote.frank@gmx.net>
-Stéphane Payrard <stef@mongueurs.net>
Stepan Kasal <skasal@redhat.com>
-Stephane Payrard <properler@freesurf.fr>
+Stéphane Payrard <stef@mongueurs.net>
Stephanie Beals <bealzy@us.ibm.com>
Stephen Bennett <sbp@exherbo.com>
Stephen Clouse <stephenc@theiqgroup.com>
Ulrich Habel <rhaen@NetBSD.org>
Ulrich Kunitz <kunitz@mai-koeln.com>
Ulrich Pfeifer <pfeifer@wait.de>
-Unicode Consortium <unicode.org>
+Unicode Consortium <unicode.org>
Vadim Konovalov <vkonovalov@lucent.com>
Valeriy E. Ushakov <uwe@ptc.spbu.ru>
Vernon Lyon <vlyon@cpan.org>
Yves Orton <demerphq@gmail.com>
Zachary Miller <zcmiller@simon.er.usgs.gov>
Zachary Storer <zacts.3.14159@gmail.com>
+Zbynek Vyskovsky <kvr@centrum.cz>
Zefram <zefram@fysh.org>
Zsbán Ambrus <ambrus@math.bme.hu>
-Zbynek Vyskovsky <kvr@centrum.cz>
Ævar Arnfjörð Bjarmason <avar@cpan.org>
-Mohammed El-Afifi <mohammed_elafifi@yahoo.com>
d_ftime=''
d_gettimeod=''
d_futimes=''
+d_gai_strerror=''
d_Gconvert=''
d_getaddrinfo=''
d_getcwd=''
*** Please select one or the other.
EOM
exit 1
- ;;
+ ;;
esac
: Looking for optional libraries
printf("8\n");
exit(0);
}
+#endif
+/* We are largely making this up because it may well be
+ * that the VAX format H was never made available to C,
+ * only to Fortran. */
+#if LONGDBLSIZE == 16 && defined(__vax__)
+ if (b[0] == 0xFD && b[15] == 0x99) {
+ /* VAX format H, PDP-11 mixed endian. */
+ printf("9\n");
+ exit(0);
+ }
#endif
printf("-1\n"); /* unknown */
exit(0);
4) echo "You have x86 80-bit big endian long doubles." >& 4 ;;
5) echo "You have 128-bit fully little-endian double-double long doubles (64-bit LEs in LE)." >& 4 ;;
6) echo "You have 128-bit fully big-endian double-double long doubles (64-bit BEs in BE)." >& 4 ;;
-7) echo "You have 128-bit mixed double-double long doubles (64-bit LEs in BE)." >& 4 ;;
-8) echo "You have 128-bit mixed double-double long doubles (64-bit BEs in LE)." >& 4 ;;
+7) echo "You have 128-bit mixed-endian double-double long doubles (64-bit LEs in BE)." >& 4 ;;
+8) echo "You have 128-bit mixed-endian double-double long doubles (64-bit BEs in LE)." >& 4 ;;
+9) echo "You have 128-bit PDP-style mixed-endian long doubles." >& 4 ;;
*) echo "Cannot figure out your long double." >&4 ;;
esac
$rm_try
fi
$rm_try
+: look for gai_strerror
+echo " "
+$cat >try.c <<'EOCP'
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <netdb.h>
+int main ()
+{
+ return (gai_strerror (0) ? 0 : 1);
+ }
+EOCP
+set try
+val="$undef"
+if eval $compile; then
+ `$run ./try`
+ case "$?" in
+ 0) echo "A working gai_strerror() found." >&4
+ val="$define" ;;
+ *) echo "gai_strerror() found, but it doesn't work" >&4
+ ;;
+ esac
+else
+ echo "gai_strerror() NOT found." >&4
+ fi
+set d_gai_strerror
+eval $setvar
+$rm_try
+
: see if ndbm.h is available
set ndbm.h i_ndbm
eval $inhdr
: Check what kind of inf/nan your system has
$echo "Checking the kind of infinities and nans you have..." >&4
+$echo "(The following tests may crash. That's okay.)" >&4
$cat >try.c <<EOP
#define DOUBLESIZE $doublesize
#$d_longdbl HAS_LONG_DOUBLE
d_ftello='$d_ftello'
d_ftime='$d_ftime'
d_futimes='$d_futimes'
+d_gai_strerror='$d_gai_strerror'
d_gdbm_ndbm_h_uses_prototypes='$d_gdbm_ndbm_h_uses_prototypes'
d_gdbmndbm_h_uses_prototypes='$d_gdbmndbm_h_uses_prototypes'
d_getaddrinfo='$d_getaddrinfo'
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='3'
+api_subversion='4'
api_version='25'
-api_versionstring='5.25.3'
+api_versionstring='5.25.4'
ar='ar'
-archlib='/usr/lib/perl5/5.25.3/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.3/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.4/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.4/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='cc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.3/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.4/armv4l-linux/CORE'
ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccname='arm-linux-gcc'
d_ftello='define'
d_ftime='undef'
d_futimes='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='stdarg.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs='y'
inc_version_list=' '
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='./install_me_here/usr/lib/perl5/5.25.3/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.4/armv4l-linux'
installbin='./install_me_here/usr/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='./install_me_here/usr/share/man/man3'
installprefix='./install_me_here/usr'
installprefixexp='./install_me_here/usr'
-installprivlib='./install_me_here/usr/lib/perl5/5.25.3'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.4'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.3/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.4/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.3'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.4'
installsiteman1dir='./install_me_here/usr/share/man/man1'
installsiteman3dir='./install_me_here/usr/share/man/man3'
installsitescript='./install_me_here/usr/bin'
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/usr/lib/perl5/5.25.3'
-privlibexp='/usr/lib/perl5/5.25.3'
+privlib='/usr/lib/perl5/5.25.4'
+privlibexp='/usr/lib/perl5/5.25.4'
procselfexe='"/proc/self/exe"'
prototype='define'
ptrsize='4'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0'
sig_size='68'
signal_t='void'
-sitearch='/usr/lib/perl5/site_perl/5.25.3/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.3/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.4/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.4/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.3'
+sitelib='/usr/lib/perl5/site_perl/5.25.4'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.3'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.4'
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='4'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.3'
-version_patchlevel_string='version 25 subversion 3'
+version='5.25.4'
+version_patchlevel_string='version 25 subversion 4'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=3
+PERL_SUBVERSION=4
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=3
+PERL_API_SUBVERSION=4
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='3'
+api_subversion='4'
api_version='25'
-api_versionstring='5.25.3'
+api_versionstring='5.25.4'
ar='ar'
-archlib='/usr/lib/perl5/5.25.3/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.3/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.4/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.4/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='arm-none-linux-gnueabi-gcc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.3/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.4/armv4l-linux/CORE'
ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccname='arm-linux-gcc'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='./install_me_here/usr/lib/perl5/5.25.3/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.4/armv4l-linux'
installbin='./install_me_here/usr/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='./install_me_here/usr/share/man/man3'
installprefix='./install_me_here/usr'
installprefixexp='./install_me_here/usr'
-installprivlib='./install_me_here/usr/lib/perl5/5.25.3'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.4'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.3/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.4/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.3'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.4'
installsiteman1dir='./install_me_here/usr/share/man/man1'
installsiteman3dir='./install_me_here/usr/share/man/man3'
installsitescript='./install_me_here/usr/bin'
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/usr/lib/perl5/5.25.3'
-privlibexp='/usr/lib/perl5/5.25.3'
+privlib='/usr/lib/perl5/5.25.4'
+privlibexp='/usr/lib/perl5/5.25.4'
procselfexe='"/proc/self/exe"'
prototype='define'
ptrsize='4'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0'
sig_size='68'
signal_t='void'
-sitearch='/usr/lib/perl5/site_perl/5.25.3/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.3/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.4/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.4/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.3'
+sitelib='/usr/lib/perl5/site_perl/5.25.4'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.3'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.4'
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='4'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.3'
-version_patchlevel_string='version 25 subversion 3'
+version='5.25.4'
+version_patchlevel_string='version 25 subversion 4'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=3
+PERL_SUBVERSION=4
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=3
+PERL_API_SUBVERSION=4
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
=item Directories for the perl distribution
-By default, Configure will use the following directories for 5.25.3.
+By default, Configure will use the following directories for 5.25.4.
$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
B<perl -d your_script>. If, however, you want to debug perl itself,
you probably want to have support for perl internal debugging code
(activated by adding -DDEBUGGING to ccflags), and/or support for the
-system debugger by adding -g to the optimisation flags. For that,
-use the parameter:
+system debugger by adding -g to the optimisation flags.
- sh Configure -DDEBUGGING
+A perl compiled with the DEBUGGING C preprocessor macro will support the
+C<-D> perl command-line switch, have assertions enabled, and have many
+extra checks compiled into the code; but will execute much more slowly
+(typically 2-3x) and the binary will be much larger (typically 2-3x).
-or
-
- sh Configure -DDEBUGGING=<mode>
-
-For a more eye appealing call, -DEBUGGING is defined to be an alias
-for -DDEBUGGING. For both, the -U calls are also supported, in order
-to be able to overrule the hints or Policy.sh settings.
+As a convenience, debugging code (-DDEBUGGING) and debugging symbols (-g)
+can be enabled jointly or separately using a Configure switch, also
+(somewhat confusingly) named -DDEBUGGING. For a more eye appealing call,
+-DEBUGGING is defined to be an alias for -DDEBUGGING. For both, the -U
+calls are also supported, in order to be able to overrule the hints or
+Policy.sh settings.
Here are the DEBUGGING modes:
=over 4
-=item -DDEBUGGING
+=item Configure -DDEBUGGING
-=item -DEBUGGING
+=item Configure -DEBUGGING
-=item -DEBUGGING=both
+=item Configure -DEBUGGING=both
Sets both -DDEBUGGING in the ccflags, and adds -g to optimize.
You can actually specify -g and -DDEBUGGING independently (see below),
but usually it's convenient to have both.
-=item -DEBUGGING=-g
+=item Configure -DEBUGGING=-g
-=item -Doptimize=-g
+=item Configure -Doptimize=-g
Adds -g to optimize, but does not set -DDEBUGGING.
(Note: Your system may actually require something like cc -g2.
Check your man pages for cc(1) and also any hint file for your system.)
-=item -DEBUGGING=none
+=item Configure -DEBUGGING=none
-=item -UDEBUGGING
+=item Configure -UDEBUGGING
Removes -g from optimize, and -DDEBUGGING from ccflags.
=head1 Coexistence with earlier versions of perl 5
-Perl 5.25.3 is not binary compatible with earlier versions of Perl.
+Perl 5.25.4 is not binary compatible with earlier versions of Perl.
In other words, you will have to recompile your XS modules.
In general, you can usually safely upgrade from one version of Perl
libraries after 5.6.0, but not for executables. TODO?) One convenient
way to do this is by using a separate prefix for each version, such as
- sh Configure -Dprefix=/opt/perl5.25.3
+ sh Configure -Dprefix=/opt/perl5.25.4
-and adding /opt/perl5.25.3/bin to the shell PATH variable. Such users
+and adding /opt/perl5.25.4/bin to the shell PATH variable. Such users
may also wish to add a symbolic link /usr/local/bin/perl so that
scripts can still start with #!/usr/local/bin/perl.
=head2 Upgrading from 5.25.2 or earlier
-B<Perl 5.25.3 may not be binary compatible with Perl 5.25.2 or
+B<Perl 5.25.4 may not be binary compatible with Perl 5.25.3 or
earlier Perl releases.> Perl modules having binary parts
(meaning that a C compiler is used) will have to be recompiled to be
-used with 5.25.3. If you find you do need to rebuild an extension with
-5.25.3, you may safely do so without disturbing the older
+used with 5.25.4. If you find you do need to rebuild an extension with
+5.25.4, you may safely do so without disturbing the older
installations. (See L<"Coexistence with earlier versions of perl 5">
above.)
print("$f\n");
}
-in Linux with perl-5.25.3 is as follows (under $Config{prefix}):
+in Linux with perl-5.25.4 is as follows (under $Config{prefix}):
./bin/perl
- ./lib/perl5/5.25.3/strict.pm
- ./lib/perl5/5.25.3/warnings.pm
- ./lib/perl5/5.25.3/i686-linux/File/Glob.pm
- ./lib/perl5/5.25.3/feature.pm
- ./lib/perl5/5.25.3/XSLoader.pm
- ./lib/perl5/5.25.3/i686-linux/auto/File/Glob/Glob.so
+ ./lib/perl5/5.25.4/strict.pm
+ ./lib/perl5/5.25.4/warnings.pm
+ ./lib/perl5/5.25.4/i686-linux/File/Glob.pm
+ ./lib/perl5/5.25.4/feature.pm
+ ./lib/perl5/5.25.4/XSLoader.pm
+ ./lib/perl5/5.25.4/i686-linux/auto/File/Glob/Glob.so
Secondly, for perl-5.10.1, the Debian perl-base package contains 591
files, (of which 510 are for lib/unicore) totaling about 3.5MB in its
cpan/CPAN/t/03pkgs.t See if CPAN::Version works
cpan/CPAN/t/10version.t See if CPAN the module works
cpan/CPAN/t/11mirroredby.t See if CPAN::Mirrored::By works
+cpan/CPAN-Meta/corpus/BadMETA.yml
+cpan/CPAN-Meta/corpus/bareyaml.meta
+cpan/CPAN-Meta/corpus/CL018_yaml.meta
+cpan/CPAN-Meta/corpus/json.meta
+cpan/CPAN-Meta/corpus/META-VR.json
+cpan/CPAN-Meta/corpus/META-VR.yml
+cpan/CPAN-Meta/corpus/yaml.meta
cpan/CPAN-Meta/lib/CPAN/Meta.pm
cpan/CPAN-Meta/lib/CPAN/Meta/Converter.pm
cpan/CPAN-Meta/lib/CPAN/Meta/Feature.pm
cpan/CPAN-Meta/lib/CPAN/Meta/Prereqs.pm
cpan/CPAN-Meta/lib/CPAN/Meta/Spec.pm
cpan/CPAN-Meta/lib/CPAN/Meta/Validator.pm
+cpan/CPAN-Meta/lib/Parse/CPAN/Meta.pm
cpan/CPAN-Meta/t/converter.t
cpan/CPAN-Meta/t/converter-bad.t
cpan/CPAN-Meta/t/converter-fail.t
cpan/CPAN-Meta/t/data-test/version-not-normal.json
cpan/CPAN-Meta/t/data-test/version-ranges-1_4.yml
cpan/CPAN-Meta/t/data-test/version-ranges-2.json
+cpan/CPAN-Meta/t/data-test/x_deprecated-META.json
cpan/CPAN-Meta/t/data-valid/1122575719-META.yml
cpan/CPAN-Meta/t/data-valid/1206545041-META.yml
cpan/CPAN-Meta/t/data-valid/1985684504-META.yml
cpan/CPAN-Meta/t/data-valid/476602558-META.yml
cpan/CPAN-Meta/t/data-valid/META-1_0.yml
cpan/CPAN-Meta/t/data-valid/META-1_1.yml
+cpan/CPAN-Meta/t/data-valid/META-1_4.yml
+cpan/CPAN-Meta/t/data-valid/META-2.json
cpan/CPAN-Meta/t/data-valid/scalar-meta-spec.yml
+cpan/CPAN-Meta/t/data-valid/x_deprecated-META.yml
+cpan/CPAN-Meta/t/lib/Parse/CPAN/Meta/Test.pm
cpan/CPAN-Meta/t/load-bad.t
cpan/CPAN-Meta/t/merge.t
cpan/CPAN-Meta/t/meta-obj.t
cpan/CPAN-Meta/t/no-index.t
cpan/CPAN-Meta/t/optional_feature-merge.t
+cpan/CPAN-Meta/t/parse-cpan-meta/02_api.t
+cpan/CPAN-Meta/t/parse-cpan-meta/03_functions.t
+cpan/CPAN-Meta/t/parse-cpan-meta/04_export.t
+cpan/CPAN-Meta/t/parse-cpan-meta/05_errors.t
cpan/CPAN-Meta/t/prereqs.t
cpan/CPAN-Meta/t/prereqs-finalize.t
cpan/CPAN-Meta/t/prereqs-merge.t
+cpan/CPAN-Meta/t/README-data.txt
cpan/CPAN-Meta/t/repository.t
cpan/CPAN-Meta/t/save-load.t
cpan/CPAN-Meta/t/validator.t
cpan/HTTP-Tiny/t/001_api.t
cpan/HTTP-Tiny/t/002_croakage.t
cpan/HTTP-Tiny/t/003_agent.t
+cpan/HTTP-Tiny/t/004_timeout.t
cpan/HTTP-Tiny/t/010_url.t
cpan/HTTP-Tiny/t/020_headers.t
cpan/HTTP-Tiny/t/030_response.t
cpan/parent/t/parent-classfromfile.t tests for parent.pm
cpan/parent/t/parent-pmc.t tests for parent.pm
cpan/parent/t/parent-returns-false.t tests for parent.pm
-cpan/Parse-CPAN-Meta/corpus/BadMETA.yml
-cpan/Parse-CPAN-Meta/corpus/bareyaml.meta
-cpan/Parse-CPAN-Meta/corpus/CL018_yaml.meta
-cpan/Parse-CPAN-Meta/corpus/json.meta
-cpan/Parse-CPAN-Meta/corpus/META-VR.json
-cpan/Parse-CPAN-Meta/corpus/META-VR.yml
-cpan/Parse-CPAN-Meta/corpus/yaml.meta
-cpan/Parse-CPAN-Meta/lib/Parse/CPAN/Meta.pm
-cpan/Parse-CPAN-Meta/t/02_api.t
-cpan/Parse-CPAN-Meta/t/03_functions.t
-cpan/Parse-CPAN-Meta/t/04_export.t
-cpan/Parse-CPAN-Meta/t/05_errors.t
-cpan/Parse-CPAN-Meta/t/lib/Parse/CPAN/Meta/Test.pm
cpan/Perl-OSType/lib/Perl/OSType.pm Perl::OSType
cpan/Perl-OSType/t/OSType.t Perl::OSType
cpan/perlfaq/lib/perlfaq.pm Perl frequently asked questions
cpan/Pod-Perldoc/lib/Pod/Perldoc/ToXml.pm convert POD to XML
cpan/Pod-Perldoc/Makefile.PL
cpan/Pod-Perldoc/perldoc.pod
-cpan/Pod-Perldoc/t/load.t test file for Pod-Perldoc
+cpan/Pod-Perldoc/t/00_load.t test file for Pod-Perldoc
+cpan/Pod-Perldoc/t/01_about_verbose.t test file for Pod-Perldoc
cpan/Pod-Perldoc/t/man/_get_columns.t test file for Pod-Perldoc
cpan/Pod-Perldoc/t/pod.t test file for Pod-Perldoc
cpan/Pod-Simple/lib/Pod/Simple.pm Pod made simple
cpan/Test-Simple/t/regression/642_persistent_end.t
cpan/Test-Simple/t/regression/662-tbt-no-plan.t
cpan/Test-Simple/t/regression/684-nested_todo_diag.t
+cpan/Test-Simple/t/regression/694_note_diag_return_values.t
cpan/Test-Simple/t/regression/no_name_in_subtest.t
cpan/Test-Simple/t/Test2/acceptance/try_it_done_testing.t
cpan/Test-Simple/t/Test2/acceptance/try_it_fork.t
dist/base/t/fields-5_6_0.t See if fields work
dist/base/t/fields-5_8_0.t See if fields work
dist/base/t/fields-base.t See if fields work
+dist/base/t/incdot.t Test how base.pm handles '.' in @INC
dist/base/t/isa.t See if base's behaviour doesn't change
dist/base/t/lib/Broken.pm Test module for base.pm
dist/base/t/lib/Dummy.pm Test module for base.pm
lib/h2xs.t See if h2xs produces expected lists of files
lib/integer.pm For "use integer"
lib/integer.t For "use integer" testing
+lib/Internals.pod Document the Internals namespace (implemented by universal.c)
lib/Internals.t For Internals::* testing
lib/less.pm For "use less"
lib/less.t See if less support works
lib/locale.pm For "use locale"
lib/locale.t See if locale support works
+lib/locale_threads.t Tes locale and threads interactions
lib/meta_notation.pm Helper for certain /lib .pm's
lib/meta_notation.t See if meta_notation.t works
lib/Net/hostent.pm By-name interface to Perl's builtin gethost*
pod/perl5250delta.pod Perl changes in version 5.25.0
pod/perl5251delta.pod Perl changes in version 5.25.1
pod/perl5252delta.pod Perl changes in version 5.25.2
+pod/perl5253delta.pod Perl changes in version 5.25.3
pod/perl561delta.pod Perl changes in version 5.6.1
pod/perl56delta.pod Perl changes in version 5.6
pod/perl581delta.pod Perl changes in version 5.8.1
t/porting/re_context.t Check assumptions made by save_re_context()
t/porting/readme.t Check that all files in Porting/ are mentioned in Porting/README.pod
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/ss_dup.t Check that sv.c:ss_dup handles everything
t/porting/test_bootstrap.t Test that the instructions for test bootstrapping aren't accidentally overlooked.
t/porting/utils.t Check that utility scripts still compile
t/re/anyof.t See if bracketed char classes [...] compile properly
"perl5-porters@perl.org"
],
"dynamic_config" : 1,
- "generated_by" : "CPAN::Meta version 2.150005",
+ "generated_by" : "CPAN::Meta version 2.150010",
"license" : [
"perl_5"
],
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.025003",
- "x_serialization_backend" : "JSON::PP version 2.27400"
+ "version" : "5.025004",
+ "x_serialization_backend" : "JSON::PP version 2.27400_01"
}
- perl5-porters@perl.org
build_requires: {}
dynamic_config: 1
-generated_by: 'CPAN::Meta version 2.150005, CPAN::Meta::Converter version 2.150005'
+generated_by: 'CPAN::Meta version 2.150010, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.025003'
+version: '5.025004'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
perllib_objs = $(perllib_objs_nodt) $(DTRACE_PERLLIB_O)
perlmain_objs = perlmain$(OBJ_EXT) $(DTRACE_MAIN_O)
-perltoc_pod_prereqs = extra.pods pod/perl5253delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl5254delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
generated_pods = pod/perltoc.pod $(perltoc_pod_prereqs)
generated_headers = uudmap.h bitcount.h mg_data.h
pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST
$(MINIPERL) pod/perlmodlib.PL -q
-pod/perl5253delta.pod: pod/perldelta.pod
- $(RMS) pod/perl5253delta.pod
- $(LNS) perldelta.pod pod/perl5253delta.pod
+pod/perl5254delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl5254delta.pod
+ $(LNS) perldelta.pod pod/perl5254delta.pod
extra.pods: $(MINIPERL_EXE)
-@test ! -f extra.pods || rm -f `cat extra.pods`
# Here comes the CW tools - TO BE FILLED TO BUILD WITH CW -
-MODULE_DESC = "Perl 5.25.3 for NetWare"
+MODULE_DESC = "Perl 5.25.4 for NetWare"
CCTYPE = CodeWarrior
C_COMPILER = mwccnlm -c
CPP_COMPILER = mwccnlm
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-INST_VER = \5.25.3
+INST_VER = \5.25.4
#
# Comment this out if you DON'T want your perl installation to have
d_ftello='undef'
d_ftime='define'
d_futimes='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='varargs.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs=''
inc_version_list=''
inc_version_list_init='0'
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define ARCHLIB "c:\\perl\\5.25.3\\lib\\NetWare-x86-multi-thread" /**/
+#define ARCHLIB "c:\\perl\\5.25.4\\lib\\NetWare-x86-multi-thread" /**/
/*#define ARCHLIB_EXP "" /**/
/* ARCHNAME:
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
-#define BIN "c:\\perl\\5.25.3\\bin\\NetWare-x86-multi-thread" /**/
-#define BIN_EXP "c:\\perl\\5.25.3\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN "c:\\perl\\5.25.4\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN_EXP "c:\\perl\\5.25.4\\bin\\NetWare-x86-multi-thread" /**/
/* BYTEORDER:
* This symbol holds the hexadecimal constant defined in byteorder,
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define SITEARCH "c:\\perl\\site\\5.25.3\\lib\\NetWare-x86-multi-thread" /**/
+#define SITEARCH "c:\\perl\\site\\5.25.4\\lib\\NetWare-x86-multi-thread" /**/
/*#define SITEARCH_EXP "" /**/
/* SITELIB:
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
-#define SITELIB "c:\\perl\\site\\5.25.3\\lib" /**/
+#define SITELIB "c:\\perl\\site\\5.25.4\\lib" /**/
/*#define SITELIB_EXP "" /**/
#define SITELIB_STEM "" /**/
This variable conditionally defines the HAS_FUTIMES symbol, which
indicates to the C program that the futimes() routine is available.
+d_gai_strerror (d_gai_strerror.U):
+ This variable conditionally defines the HAS_GAI_STRERROR symbol
+ if the gai_strerror() routine is available and can be used to
+ translate error codes returned by getaddrinfo() into human
+ readable strings.
+
d_Gconvert (d_gconvert.U):
This variable holds what Gconvert is defined as to convert
floating point numbers into strings. By default, Configure
This variable, if defined, tells that there's a 64-bit integer type,
quadtype.
+d_querylocale (d_newlocale.U):
+ This variable conditionally defines the HAS_QUERYLOCALE symbol, which
+ indicates to the C program that the querylocale() routine is available
+ to return the name of the locale for a category mask.
+
d_random_r (d_random_r.U):
This variable conditionally defines the HAS_RANDOM_R symbol,
which indicates to the C program that the random_r()
This variable conditionally defines HAS_STRERROR if strerror() is
available to translate error numbers to strings.
+d_strerror_l (d_strerror_l.U):
+ This variable conditionally defines the HAS_STRERROR_L symbol, which
+ indicates to the C program that the strerror_l() routine is available
+ to return the error message for a given errno value in a particular
+ locale (identified by a locale_t object).
+
d_strerror_r (d_strerror_r.U):
This variable conditionally defines the HAS_STRERROR_R symbol,
which indicates to the C program that the strerror_r()
6 = IEEE 754 128-bit big endian,
7 = IEEE 754 64-bit mixed endian le-be,
8 = IEEE 754 64-bit mixed endian be-le,
+ 9 = VAX 32bit little endian F float format
+ 10 = VAX 64bit little endian D float format
+ 11 = VAX 64bit little endian G float format
-1 = unknown format.
doublemantbits (mantbits.U):
4 = x86 80-bit big endian,
5 = double-double 128-bit little endian,
6 = double-double 128-bit big endian,
- 7 = 128-bit mixed double-double (64-bit LEs in BE),
- 8 = 128-bit mixed double-double (64-bit BEs in LE),
+ 7 = 128-bit mixed-endian double-double (64-bit LEs in BE),
+ 8 = 128-bit mixed-endian double-double (64-bit BEs in LE),
+ 9 = 128-bit PDP-style mixed-endian long doubles,
-1 = unknown format.
longdblmantbits (mantbits.U):
%Modules = (
'Archive::Tar' => {
- 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.08.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.10.tar.gz',
'FILES' => q[cpan/Archive-Tar],
'BUGS' => 'bug-archive-tar@rt.cpan.org',
'EXCLUDED' => [
'base' => {
'DISTRIBUTION' => 'RJBS/base-2.23.tar.gz',
'FILES' => q[dist/base],
+ 'CUSTOMIZED' => [
+ # https://rt.perl.org/Ticket/Display.html?id=127834
+ qw( lib/base.pm )
+ ],
},
'bignum' => {
t/03podcov.t
),
],
+ 'CUSTOMIZED' => [
+ qw(
+ lib/Math/BigFloat/Trace.pm
+ lib/Math/BigInt/Trace.pm lib/bigint.pm
+ lib/bignum.pm lib/bigrat.pm
+ )
+ ],
},
'Carp' => {
},
'Config::Perl::V' => {
- 'DISTRIBUTION' => 'HMBRAND/Config-Perl-V-0.26.tgz',
+ 'DISTRIBUTION' => 'HMBRAND/Config-Perl-V-0.27.tgz',
'FILES' => q[cpan/Config-Perl-V],
'EXCLUDED' => [qw(
examples/show-v.pl
t/yaml_code.yml
),
],
+ 'CUSTOMIZED' => [
+ # CVE-2016-1238
+ qw(
+ lib/App/Cpan.pm lib/CPAN.pm scripts/cpan
+ )
+ ],
},
# Note: When updating CPAN-Meta the META.* files will need to be regenerated
# perl -Icpan/CPAN-Meta/lib Porting/makemeta
'CPAN::Meta' => {
- 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-2.150005.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-2.150010.tar.gz',
'FILES' => q[cpan/CPAN-Meta],
'EXCLUDED' => [
qw[t/00-report-prereqs.t
t/00-report-prereqs.dd
- t/data-test/x_deprecated-META.json
- t/data-valid/x_deprecated-META.yml
- t/README-data.txt],
+ ],
qr{^xt},
qr{^history},
],
'DISTRIBUTION' => 'GAAS/Digest-1.17.tar.gz',
'FILES' => q[cpan/Digest],
'EXCLUDED' => ['digest-bench'],
+ 'CUSTOMIZED' => [
+ # CVE-2016-1238
+ qw( Digest.pm )
+ ],
},
'Digest::MD5' => {
},
'Digest::SHA' => {
- 'DISTRIBUTION' => 'MSHELOR/Digest-SHA-5.95.tar.gz',
+ 'DISTRIBUTION' => 'MSHELOR/Digest-SHA-5.96.tar.gz',
'FILES' => q[cpan/Digest-SHA],
'EXCLUDED' => [
qw( t/pod.t
},
'Encode' => {
- 'DISTRIBUTION' => 'DANKOGAI/Encode-2.84.tar.gz',
+ 'DISTRIBUTION' => 'DANKOGAI/Encode-2.86.tar.gz',
'FILES' => q[cpan/Encode],
- CUSTOMIZED => [
- qw( encoding.pm
- Byte/Makefile.PL
- t/enc_data.t
- t/enc_eucjp.t
- t/enc_module.t
- t/enc_utf8.t
- t/encoding.t
- t/jperl.t
- ),
- ],
+ 'CUSTOMIZED' => [ qw[ Encode.xs ] ],
},
'encoding::warnings' => {
},
'ExtUtils::MakeMaker' => {
- 'DISTRIBUTION' => 'BINGOS/ExtUtils-MakeMaker-7.18.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/ExtUtils-MakeMaker-7.24.tar.gz',
'FILES' => q[cpan/ExtUtils-MakeMaker],
'EXCLUDED' => [
qr{^t/lib/Test/},
'README.packaging',
'lib/ExtUtils/MakeMaker/version/vpp.pm',
],
- 'CUSTOMIZED' => [ qw( t/basic.t t/lib/MakeMaker/Test/Setup/XS.pm ) ],
},
'ExtUtils::Manifest' => {
},
'File::Fetch' => {
- 'DISTRIBUTION' => 'BINGOS/File-Fetch-0.48.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/File-Fetch-0.52.tar.gz',
'FILES' => q[cpan/File-Fetch],
},
},
'HTTP::Tiny' => {
- 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.058.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.064.tar.gz',
'FILES' => q[cpan/HTTP-Tiny],
'EXCLUDED' => [
't/00-report-prereqs.t',
't/010examples-zlib.t',
't/cz-05examples.t',
],
+ 'CUSTOMIZED' => [
+ # CVE-2016-1238
+ qw(
+ bin/zipdetails lib/Compress/Zlib.pm
+ lib/IO/Compress/Adapter/Bzip2.pm
+ lib/IO/Compress/Adapter/Deflate.pm
+ lib/IO/Compress/Adapter/Identity.pm
+ lib/IO/Compress/Base.pm
+ lib/IO/Compress/Base/Common.pm
+ lib/IO/Compress/Bzip2.pm
+ lib/IO/Compress/Deflate.pm
+ lib/IO/Compress/Gzip.pm
+ lib/IO/Compress/Gzip/Constants.pm
+ lib/IO/Compress/RawDeflate.pm
+ lib/IO/Compress/Zip.pm
+ lib/IO/Compress/Zip/Constants.pm
+ lib/IO/Compress/Zlib/Constants.pm
+ lib/IO/Compress/Zlib/Extra.pm
+ lib/IO/Uncompress/Adapter/Bunzip2.pm
+ lib/IO/Uncompress/Adapter/Identity.pm
+ lib/IO/Uncompress/Adapter/Inflate.pm
+ lib/IO/Uncompress/AnyInflate.pm
+ lib/IO/Uncompress/AnyUncompress.pm
+ lib/IO/Uncompress/Base.pm
+ lib/IO/Uncompress/Bunzip2.pm
+ lib/IO/Uncompress/Gunzip.pm
+ lib/IO/Uncompress/Inflate.pm
+ lib/IO/Uncompress/RawInflate.pm
+ lib/IO/Uncompress/Unzip.pm
+ )
+ ],
},
'IO::Socket::IP' => {
- 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.37.tar.gz',
+ 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.38.tar.gz',
'FILES' => q[cpan/IO-Socket-IP],
'EXCLUDED' => [
qr{^examples/},
},
'IPC::Cmd' => {
- 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.94.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.96.tar.gz',
'FILES' => q[cpan/IPC-Cmd],
},
'JSON::PP' => {
'DISTRIBUTION' => 'MAKAMAKA/JSON-PP-2.27400.tar.gz',
'FILES' => q[cpan/JSON-PP],
+ 'CUSTOMIZED' => [
+ # CVE-2016-1238
+ qw( bin/json_pp lib/JSON/PP.pm ),
+ ],
},
'lib' => {
},
'libnet' => {
- 'DISTRIBUTION' => 'SHAY/libnet-3.09.tar.gz',
+ 'DISTRIBUTION' => 'SHAY/libnet-3.10.tar.gz',
'FILES' => q[cpan/libnet],
'EXCLUDED' => [
qw( Configure
},
'Locale::Maketext' => {
- 'DISTRIBUTION' => 'TODDR/Locale-Maketext-1.27.tar.gz',
+ 'DISTRIBUTION' => 'TODDR/Locale-Maketext-1.28.tar.gz',
'FILES' => q[dist/Locale-Maketext],
'EXCLUDED' => [
qw(
'Locale::Maketext::Simple' => {
'DISTRIBUTION' => 'JESSE/Locale-Maketext-Simple-0.21.tar.gz',
'FILES' => q[cpan/Locale-Maketext-Simple],
+ 'CUSTOMIZED' => [
+ # CVE-2016-1238
+ qw( lib/Locale/Maketext/Simple.pm )
+ ],
},
'Math::BigInt' => {
'DISTRIBUTION' => 'MJD/Memoize-1.03.tgz',
'FILES' => q[cpan/Memoize],
'EXCLUDED' => ['article.html'],
+ 'CUSTOMIZED' => [
+ # CVE-2016-1238
+ qw( Memoize.pm )
+ ],
},
'MIME::Base64' => {
},
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20160620.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20160720.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
},
'Module::Load::Conditional' => {
- 'DISTRIBUTION' => 'BINGOS/Module-Load-Conditional-0.64.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-Load-Conditional-0.68.tar.gz',
'FILES' => q[cpan/Module-Load-Conditional],
},
},
'Module::Metadata' => {
- 'DISTRIBUTION' => 'ETHER/Module-Metadata-1.000032-TRIAL.tar.gz',
+ 'DISTRIBUTION' => 'ETHER/Module-Metadata-1.000033.tar.gz',
'FILES' => q[cpan/Module-Metadata],
'EXCLUDED' => [
qw(t/00-report-prereqs.t),
qr{weaver.ini},
qr{^xt},
],
- # https://rt.perl.org/Ticket/Display.html?id=128160
- # https://github.com/Perl-Toolchain-Gang/Module-Metadata/commit/59b3f5b45ff862a1a422a409518255736fe81b66
- 'CUSTOMIZED' => [ qw[ t/extract-package.t t/metadata.t ] ],
},
'Net::Ping' => {
},
'NEXT' => {
- 'DISTRIBUTION' => 'FLORA/NEXT-0.65.tar.gz',
+ 'DISTRIBUTION' => 'NEILB/NEXT-0.67.tar.gz',
'FILES' => q[cpan/NEXT],
'EXCLUDED' => [qr{^demo/}],
},
'FILES' => q[cpan/parent],
},
- 'Parse::CPAN::Meta' => {
- 'DISTRIBUTION' => 'DAGOLDEN/Parse-CPAN-Meta-1.4422.tar.gz',
- 'FILES' => q[cpan/Parse-CPAN-Meta],
- 'EXCLUDED' => [
- qw[t/00-report-prereqs.dd],
- qw[t/00-report-prereqs.t],
- qr{^xt},
- ],
- },
-
'PathTools' => {
'DISTRIBUTION' => 'RJBS/PathTools-3.62.tar.gz',
'FILES' => q[dist/PathTools],
},
'Pod::Perldoc' => {
- 'DISTRIBUTION' => 'MALLEN/Pod-Perldoc-3.25.tar.gz',
+ 'DISTRIBUTION' => 'MALLEN/Pod-Perldoc-3.27.tar.gz',
'FILES' => q[cpan/Pod-Perldoc],
# Note that we use the CPAN-provided Makefile.PL, since it
# contains special handling of the installation of perldoc.pod
- # In blead, the perldoc executable is generated by perldoc.PL
- # instead
- # XXX We can and should fix this, but clean up the DRY-failure in utils
- # first
- 'EXCLUDED' => ['perldoc'],
-
- # https://rt.cpan.org/Ticket/Display.html?id=106798
- # https://rt.cpan.org/Ticket/Display.html?id=110368
- 'CUSTOMIZED' => [ qw[ lib/Pod/Perldoc.pm ] ],
+ 'EXCLUDED' => [
+ # In blead, the perldoc executable is generated by perldoc.PL
+ # instead
+ # XXX We can and should fix this, but clean up the DRY-failure in
+ # utils first
+ 'perldoc',
+
+ # https://rt.cpan.org/Ticket/Display.html?id=116827
+ 't/02_module_pod_output.t'
+ ],
},
'Pod::Simple' => {
win32/PerlLog.RES
),
],
+ 'CUSTOMIZED' => [
+ # CVE-2016-1238
+ qw( Syslog.pm )
+ ],
},
'Term::ANSIColor' => {
t/lib/if.pm
),
],
+ 'CUSTOMIZED' => [
+ # CVE-2016-1238
+ qw(
+ bin/prove lib/App/Prove.pm lib/App/Prove/State.pm
+ lib/App/Prove/State/Result.pm
+ lib/App/Prove/State/Result/Test.pm
+ lib/TAP/Base.pm lib/TAP/Formatter/Base.pm
+ lib/TAP/Formatter/Color.pm
+ lib/TAP/Formatter/Console.pm
+ lib/TAP/Formatter/Console/ParallelSession.pm
+ lib/TAP/Formatter/Console/Session.pm
+ lib/TAP/Formatter/File.pm
+ lib/TAP/Formatter/File/Session.pm
+ lib/TAP/Formatter/Session.pm lib/TAP/Harness.pm
+ lib/TAP/Harness/Env.pm lib/TAP/Object.pm
+ lib/TAP/Parser.pm lib/TAP/Parser/Aggregator.pm
+ lib/TAP/Parser/Grammar.pm
+ lib/TAP/Parser/Iterator.pm
+ lib/TAP/Parser/Iterator/Array.pm
+ lib/TAP/Parser/Iterator/Process.pm
+ lib/TAP/Parser/Iterator/Stream.pm
+ lib/TAP/Parser/IteratorFactory.pm
+ lib/TAP/Parser/Multiplexer.pm
+ lib/TAP/Parser/Result.pm
+ lib/TAP/Parser/Result/Bailout.pm
+ lib/TAP/Parser/Result/Comment.pm
+ lib/TAP/Parser/Result/Plan.pm
+ lib/TAP/Parser/Result/Pragma.pm
+ lib/TAP/Parser/Result/Test.pm
+ lib/TAP/Parser/Result/Unknown.pm
+ lib/TAP/Parser/Result/Version.pm
+ lib/TAP/Parser/Result/YAML.pm
+ lib/TAP/Parser/ResultFactory.pm
+ lib/TAP/Parser/Scheduler.pm
+ lib/TAP/Parser/Scheduler/Job.pm
+ lib/TAP/Parser/Scheduler/Spinner.pm
+ lib/TAP/Parser/Source.pm
+ lib/TAP/Parser/SourceHandler.pm
+ lib/TAP/Parser/SourceHandler/Executable.pm
+ lib/TAP/Parser/SourceHandler/File.pm
+ lib/TAP/Parser/SourceHandler/Handle.pm
+ lib/TAP/Parser/SourceHandler/Perl.pm
+ lib/TAP/Parser/SourceHandler/RawTAP.pm
+ lib/TAP/Parser/YAMLish/Reader.pm
+ lib/TAP/Parser/YAMLish/Writer.pm
+ lib/Test/Harness.pm
+ )
+ ],
},
'Test::Simple' => {
- 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302045.tar.gz',
+ 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302052.tar.gz',
'FILES' => q[cpan/Test-Simple],
'EXCLUDED' => [
qr{^examples/},
qr{^xt/},
- qw( perltidyrc
+ qw( appveyor.yml
+ perltidyrc
t/00compile.t
t/00-report.t
t/zzz-check-breaks.t
},
'Time::Local' => {
- 'DISTRIBUTION' => 'DROLSKY/Time-Local-1.2300.tar.gz',
+ 'DISTRIBUTION' => 'DROLSKY/Time-Local-1.24.tar.gz',
'FILES' => q[cpan/Time-Local],
'EXCLUDED' => [
- qr{^t/release-.*\.t},
+ qr{^xt/},
+ qw( perlcriticrc
+ perltidyrc
+ tidyall.ini
+ t/00-report-prereqs.t
+ t/00-report-prereqs.dd
+ ),
],
},
lib/FileHandle.{pm,t}
lib/FindBin.{pm,t}
lib/Getopt/Std.{pm,t}
+ lib/Internals.pod
lib/Internals.t
lib/meta_notation.{pm,t}
lib/Net/hostent.{pm,t}
lib/integer.{pm,t}
lib/less.{pm,t}
lib/locale.{pm,t}
+ lib/locale_threads.t
lib/open.{pm,t}
lib/overload/numbers.pm
lib/overloading.{pm,t}
show_results process_options files_to_modules
finish_tap_output
reload_manifest);
-$VERSION = 0.10;
+$VERSION = 0.11;
require Exporter;
sub warn_maintainer {
my $name = shift;
- ok($files{$name}, "$name has a maintainer");
+ ok($files{$name}, "$name has a maintainer (see Porting/Maintainer.pl)");
}
sub missing_maintainers {
+ hanekomu\100gmail.com
marcgreen\100cpan.org marcgreen\100wpi.edu
markleightonfisher\100gmail.com fisherm\100tce.com
++ mark-fisher\100mindspring.com
mark.p.lutz\100boeing.com tecmpl1\100triton.ca.boeing.com
marnix\100gmail.com pttesac!marnix!vanam
marty+p5p\100kasei.com marty\100martian.org
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='3'
+api_subversion='4'
api_version='25'
-api_versionstring='5.25.3'
+api_versionstring='5.25.4'
ar='ar'
-archlib='/tmp/mblead/lib/perl5/5.25.3/darwin-2level'
-archlibexp='/tmp/mblead/lib/perl5/5.25.3/darwin-2level'
+archlib='/tmp/mblead/lib/perl5/5.25.4/darwin-2level'
+archlibexp='/tmp/mblead/lib/perl5/5.25.4/darwin-2level'
archname64=''
archname='darwin-2level'
archobjs=''
d_ftello='define'
d_ftime='undef'
d_futimes='define'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='define'
incpth='/usr/local/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/../lib/clang/6.0/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/include /usr/include /usr/local/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/../lib/clang/6.0/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/include /usr/include /usr/local/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/../lib/clang/6.0/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/include /usr/include'
inews=''
initialinstalllocation='/tmp/mblead/bin'
-installarchlib='/tmp/mblead/lib/perl5/5.25.3/darwin-2level'
+installarchlib='/tmp/mblead/lib/perl5/5.25.4/darwin-2level'
installbin='/tmp/mblead/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='/tmp/mblead/man/man3'
installprefix='/tmp/mblead'
installprefixexp='/tmp/mblead'
-installprivlib='/tmp/mblead/lib/perl5/5.25.3'
+installprivlib='/tmp/mblead/lib/perl5/5.25.4'
installscript='/tmp/mblead/bin'
-installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.3/darwin-2level'
+installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.4/darwin-2level'
installsitebin='/tmp/mblead/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.3'
+installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.4'
installsiteman1dir='/tmp/mblead/man/man1'
installsiteman3dir='/tmp/mblead/man/man3'
installsitescript='/tmp/mblead/bin'
perl_static_inline='static __inline__'
perladmin='aaron@daybreak.nonet'
perllibs='-lpthread -ldl -lm -lutil -lc'
-perlpath='/tmp/mblead/bin/perl5.25.3'
+perlpath='/tmp/mblead/bin/perl5.25.4'
pg='pg'
phostname='hostname'
pidtype='pid_t'
pr=''
prefix='/tmp/mblead'
prefixexp='/tmp/mblead'
-privlib='/tmp/mblead/lib/perl5/5.25.3'
-privlibexp='/tmp/mblead/lib/perl5/5.25.3'
+privlib='/tmp/mblead/lib/perl5/5.25.4'
+privlibexp='/tmp/mblead/lib/perl5/5.25.4'
procselfexe=''
prototype='define'
ptrsize='8'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 6, 0'
sig_size='33'
signal_t='void'
-sitearch='/tmp/mblead/lib/perl5/site_perl/5.25.3/darwin-2level'
-sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.3/darwin-2level'
+sitearch='/tmp/mblead/lib/perl5/site_perl/5.25.4/darwin-2level'
+sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.4/darwin-2level'
sitebin='/tmp/mblead/bin'
sitebinexp='/tmp/mblead/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.3'
+sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.4'
sitelib_stem='/tmp/mblead/lib/perl5/site_perl'
-sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.3'
+sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.4'
siteman1dir='/tmp/mblead/man/man1'
siteman1direxp='/tmp/mblead/man/man1'
siteman3dir='/tmp/mblead/man/man3'
ssizetype='ssize_t'
st_ino_sign='1'
st_ino_size='8'
-startperl='#!/tmp/mblead/bin/perl5.25.3'
+startperl='#!/tmp/mblead/bin/perl5.25.4'
startsh='#!/bin/sh'
static_ext=' '
stdchar='char'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='3'
+subversion='4'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.3'
-version_patchlevel_string='version 25 subversion 3'
+version='5.25.4'
+version_patchlevel_string='version 25 subversion 4'
versiononly='define'
vi=''
xlibpth='/usr/lib/386 /lib/386'
zip='zip'
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=3
+PERL_SUBVERSION=4
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=3
+PERL_API_SUBVERSION=4
PERL_PATCHLEVEL=''
PERL_CONFIG_SH=true
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define ARCHLIB "/pro/lib/perl5/5.25.3/i686-linux-64int-ld" /**/
-#define ARCHLIB_EXP "/pro/lib/perl5/5.25.3/i686-linux-64int-ld" /**/
+#define ARCHLIB "/pro/lib/perl5/5.25.4/i686-linux-64int-ld" /**/
+#define ARCHLIB_EXP "/pro/lib/perl5/5.25.4/i686-linux-64int-ld" /**/
/* ARCHNAME:
* This symbol holds a string representing the architecture name.
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define PRIVLIB "/pro/lib/perl5/5.25.3" /**/
-#define PRIVLIB_EXP "/pro/lib/perl5/5.25.3" /**/
+#define PRIVLIB "/pro/lib/perl5/5.25.4" /**/
+#define PRIVLIB_EXP "/pro/lib/perl5/5.25.4" /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define SITEARCH "/pro/lib/perl5/site_perl/5.25.3/i686-linux-64int-ld" /**/
-#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.3/i686-linux-64int-ld" /**/
+#define SITEARCH "/pro/lib/perl5/site_perl/5.25.4/i686-linux-64int-ld" /**/
+#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.4/i686-linux-64int-ld" /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
-#define SITELIB "/pro/lib/perl5/site_perl/5.25.3" /**/
-#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.3" /**/
+#define SITELIB "/pro/lib/perl5/site_perl/5.25.4" /**/
+#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.4" /**/
#define SITELIB_STEM "/pro/lib/perl5/site_perl" /**/
/* SSize_t:
* script to make sure (one hopes) that it runs with perl and not
* some shell.
*/
-#define STARTPERL "#!/pro/bin/perl5.25.3" /**/
+#define STARTPERL "#!/pro/bin/perl5.25.4" /**/
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
../cpan/autodie/t/internal.t
../cpan/AutoLoader/t/01AutoLoader.t
../cpan/CGI/t/utf8.t
-../cpan/Encode/t/enc_data.t
-../cpan/Encode/t/encoding.t
-../cpan/Encode/t/jperl.t
-../cpan/ExtUtils-Install/t/Installapi2.t
-../cpan/ExtUtils-Install/t/Packlist.t
../cpan/ExtUtils-MakeMaker/t/xs.t
-../cpan/ExtUtils-Manifest/t/Manifest.t
../cpan/File-Path/t/taint.t
-../cpan/File-Temp/t/object.t
-../cpan/IO-Compress/t/050interop-gzip.t
-../cpan/IO-Compress/t/cz-08encoding.t
../cpan/Module-Build/t/manifypods_with_utf8.t
../cpan/Socket/t/sockaddr.t
../cpan/Term-ANSIColor/t/taint.t
../dist/Data-Dumper/t/dumper.t
../dist/Exporter/t/Exporter.t
../dist/Filter-Simple/t/data.t
-../dist/I18N-LangTags/t/50_super.t
../dist/IO/t/io_file_export.t
../dist/IO/t/io_multihomed.t
../dist/IO/t/io_sel.t
../dist/PathTools/t/cwd.t
../dist/Storable/t/blessed.t
../dist/Storable/t/croak.t
-../dist/Term-ReadLine/t/ReadLine.t
../dist/Thread-Queue/t/08_nothreads.t
-../dist/Tie-File/t/42_offset.t
../dist/bignum/t/big_e_pi.t
../dist/bignum/t/bigexp.t
../dist/bignum/t/bigint.t
../ext/B/t/optree_samples.t
../ext/B/t/xref.t
../ext/Devel-Peek/t/Peek.t
-../ext/File-Glob/t/basic.t
../ext/File-Glob/t/taint.t
../ext/Hash-Util/t/Util.t
../ext/IPC-Open3/t/IPC-Open2.t
../ext/IPC-Open3/t/IPC-Open3.t
-../ext/Opcode/t/Opcode.t
-../ext/PerlIO-via/t/via.t
../ext/XS-APItest/t/autoload.t
../ext/XS-APItest/t/blockhooks.t
../ext/XS-APItest/t/call_checker.t
../ext/XS-APItest/t/cleanup.t
../ext/XS-APItest/t/fetch_pad_names.t
-../ext/XS-APItest/t/overload.t
../ext/XS-APItest/t/svpeek.t
-../ext/XS-APItest/t/xsub_h.t
../lib/DB.t
-../lib/DBM_Filter/t/01error.t
-../lib/DBM_Filter/t/02core.t
-../lib/DBM_Filter/t/compress.t
-../lib/DBM_Filter/t/encode.t
-../lib/DBM_Filter/t/int32.t
-../lib/DBM_Filter/t/null.t
-../lib/DBM_Filter/t/utf8.t
../lib/English.t
../lib/File/Basename.t
../lib/charnames.t
-../lib/less.t
../lib/overload.t
base/lex.t # checks regexp stringification
comp/final_line_num.t # tests syntax error after BEGIN block
op/postfixderef.t
op/range.t
op/readline.t
-op/signatures.t
op/split.t
op/srand.t
op/sub.t
run/switchd-78586.t # -I on #! line is not deparsed
uni/attrs.t
uni/bless.t
-uni/greek.t
uni/gv.t
uni/labels.t
-uni/latin2.t
uni/lex_utf8.t
uni/method.t
uni/package.t
op/smartkve.t # Gobbles up all memory...
comp/redef.t # Redefinition happens at compile time
-lib/Switch/t/ # B::Deparse doesn't support source filtering
../lib/locale.t # Memory...
=head1 EPIGRAPHS
+=head2 v5.25.3 - Edward Lear, ed. Vivien Noakes, "The Complete Nonsense and Other Verse": The Dong with a Luminous Nose
+
+L<Announced on 2016-07-20 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/07/msg238158.html>
+
+ When awful darkness and silence reign
+ Over the great Gromboolian plain,
+ Through the long, long wintry nights; -
+ When the angry breakers roar
+ As they beat on the rocky shore; -
+ When Storm-clouds brood on the towering heights
+ Of the Hills of the Chankly Bore: -
+
+ Then, through the vast and gloomy dark,
+ There moves what seems a fiery spark,
+ A lonely spark with silvery rays
+ Piercing the coal-black night, -
+ A Meteor strange and bright: -
+ Hither and thither the vision strays,
+ A single lurid light.
+
+ Slowly it wanders, - pauses, - creeps, -
+ Anon it sparkles, - flashes and leaps;
+ And ever as onward it gleaming goes
+ A light on the Bong-tree stems it throws.
+ And those who watch at that midnight hour
+ From Hall or Terrace, or lofty Tower,
+ Cry, as the wild light passes along, -
+ 'The Dong! - the Dong!
+ The wandering Dong through the forest goes!
+ The Dong! the Dong!
+ The Dong with a luminous Nose!'
+
=head2 v5.25.2 - Dan le Sac Vs Scroobius Pip "Waiting For The Beat To Kick In"
L<Announced on 2016-06-20 by Matthew Horsfall|http://www.nntp.perl.org/group/perl.perl5.porters/2016/06/msg237274.html>
To find that the utmost reward
Of daring should be still to dare.
+=head2 v5.24.1-RC3 - Dante Alighieri, trans. Dorothy L. Sayers and Barbara Reynolds, "The Divine Comedy", Cantica III: Paradise, Canto XXIII
+
+L<Announced on 2016-08-11 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/08/msg238909.html>
+
+ A bird within the bower of her delight,
+ Quiet upon the nest with her sweet brood
+ Throughout the dark concealment of the night,
+
+ Anxious to look on them and gather food -
+ No weary task for her, for as at play
+ Blithely she toils to seek her fledglings' good -
+
+ Before the time, upon the topmost spray
+ Eager awaits the sun and on the East
+ Fixes her wakeful eye till break of day.
+
+=head2 v5.24.1-RC2 - Dante Alighieri, trans. Dorothy L. Sayers, "The Divine Comedy", Cantica II: Purgatory, Canto X
+
+L<Announced on 2016-07-25 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/07/msg238269.html>
+
+ When we had crossed the threshold of that gate
+ Which the soul's evil loves put out of use,
+ Because they make the crooked path seem straight,
+
+ I heard its closing clang ring clamorous,
+ And had I then turned back my eyes to it
+ How could my fault have found the least excuse?
+
+ We had to climb now through a rocky slit
+ Which ran from side to side in many a swerve,
+ As runs the wave in onset and retreat.
+
+ "Now here," the master said, "we must observe
+ Some little caution, hugging now this wall,
+ Now that, upon the far side of the curve."
+
=head2 v5.24.1-RC1 - Dante Alighieri, trans. Dorothy L. Sayers, "The Divine Comedy", Cantica I: Hell, Canto XX
L<Announced on 2016-07-17 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/07/msg238072.html>
They sing while you slave and I just get bored
I ain't gonna work on Maggie's farm no more
+=head2 v5.22.3-RC3 - Dante Alighieri, trans. Dorothy L. Sayers and Barbara Reynolds, "The Divine Comedy", Cantica III: Paradise, Canto IV
+
+L<Announced on 2016-08-11 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/08/msg238908.html>
+
+ Between two dishes, equally attractive
+ And near to him, a free man, I suppose,
+ Would starve to death before his teeth got active;
+
+ So would a lamb 'twixt two fierce wolfish foes,
+ Fearing the fangs both ways, not stir a foot;
+ So would a deerhound halt between two does;
+
+ So I can't blame myself for standing mute,
+ Nor praise myself: for I must needs so do,
+ Suspended 'twixt two doubts, alike acute.
+
+=head2 v5.22.3-RC2 - Dante Alighieri, trans. Dorothy L. Sayers, "The Divine Comedy", Cantica II: Purgatory, Canto I
+
+L<Announced on 2016-07-25 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/07/msg238270.html>
+
+ For better waters heading with the wind
+ My ship of genius now shakes out her sail
+ And leaves that ocean of despair behind;
+
+ For to the second realm I tune my tale,
+ Where human spirits purge themselves, and train
+ To leap up into joy celestial.
+
+ Now from the grave wake poetry again,
+ O sacred Muses I have served so long!
+ Now let Calliope uplift her strain
+
+ And lift my voice up on the mighty song
+ That smote the miserable Magpies nine
+ Out of all hope of pardon for their wrong!
+
=head2 v5.22.3-RC1 - Dante Alighieri, trans. Dorothy L. Sayers, "The Divine Comedy", Cantica I: Hell, Canto XII
L<Announced on 2016-07-17 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/07/msg238071.html>
use warnings;
use Getopt::Std;
+# avoid unnecessary churn in x_serialization_backend in META.*
+$ENV{PERL_JSON_BACKEND} = $ENV{CPAN_META_JSON_BACKEND} = 'JSON::PP';
+$ENV{PERL_YAML_BACKEND} = 'CPAN::Meta::YAML';
+
my $opts = {
'META.yml' => { version => '1.4' },
'META.json' => { version => '2' },
XXX Generate this with:
- perl Porting/acknowledgements.pl v5.25.3..HEAD
+ perl Porting/acknowledgements.pl v5.25.4..HEAD
=head1 Reporting Bugs
2016-04-08 5.25.0 ✓ Ricardo Signes
2016-05-20 5.25.1 ✓ Sawyer X
2016-06-20 5.25.2 ✓ Matthew Horsfall
- 2016-07-20 5.25.3 Steve Hay
+ 2016-07-20 5.25.3 ✓ Steve Hay
2016-08-20 5.25.4 BinGOs
2016-09-20 5.25.5 Stevan Little
2016-10-20 5.25.6 Chad Granum
On these systems, it might be the default compilation mode, and there
is currently no guarantee that passing no use64bitall option to the
Configure process will build a 32bit perl. Implementing -Duse32bit*
-options would be nice for perl 5.25.3.
+options would be nice for perl 5.25.4.
=head2 Profile Perl - am I hot or not?
=head1 Big projects
Tasks that will get your name mentioned in the description of the "Highlights
-of 5.25.3"
+of 5.25.4"
=head2 make ithreads more robust
Make perl executable and create a symlink for libperl:
chmod a+x /boot/common/bin/perl
- cd /boot/common/lib; ln -s perl5/5.25.3/BePC-haiku/CORE/libperl.so .
+ cd /boot/common/lib; ln -s perl5/5.25.4/BePC-haiku/CORE/libperl.so .
-Replace C<5.25.3> with your respective version of Perl.
+Replace C<5.25.4> with your respective version of Perl.
=head1 KNOWN PROBLEMS
This document briefly describes Perl under Mac OS X.
- curl -O http://www.cpan.org/src/perl-5.25.3.tar.gz
- tar -xzf perl-5.25.3.tar.gz
- cd perl-5.25.3
+ curl -O http://www.cpan.org/src/perl-5.25.4.tar.gz
+ tar -xzf perl-5.25.4.tar.gz
+ cd perl-5.25.4
./Configure -des -Dprefix=/usr/local/
make
make test
=head1 DESCRIPTION
-The latest Perl release (5.25.3 as of this writing) builds without changes
+The latest Perl release (5.25.4 as of this writing) builds without changes
under all versions of Mac OS X from 10.3 "Panther" onwards.
In order to build your own version of Perl you will need 'make',
=item Additional Perl modules
- unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.25.3/
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.25.4/
Same remark as above applies. Additionally, if this directory is not
one of directories on @INC (and @INC is influenced by C<PERLLIB_PREFIX>), you
choice. Once you have done so, use a command like the following to
unpack the archive:
- vmstar -xvf perl-5^.25^.3.tar
+ vmstar -xvf perl-5^.25^.4.tar
Then set default to the top-level source directory like so:
- set default [.perl-5^.25^.3]
+ set default [.perl-5^.25^.4]
and proceed with configuration as described in the next section.
it. There's a script in PERL_ROOT:[UTILS], perlbug, that walks you through
the process of creating a bug report. This script includes details of your
installation, and is very handy. Completed bug reports should go to
-perlbug@perl.com.
+perlbug@perl.org.
=head1 CAVEATS
SV**
Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
{
+ SSize_t neg;
+ SSize_t size;
+
PERL_ARGS_ASSERT_AV_FETCH;
assert(SvTYPE(av) == SVt_PVAV);
- if (SvRMAGICAL(av)) {
+ if (UNLIKELY(SvRMAGICAL(av))) {
const MAGIC * const tied_magic
= mg_find((const SV *)av, PERL_MAGIC_tied);
if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
}
}
- if (key < 0) {
- key += AvFILL(av) + 1;
- if (key < 0)
+ neg = (key < 0);
+ size = AvFILLp(av) + 1;
+ key += neg * size; /* handle negative index without using branch */
+
+ /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size)
+ * to be tested as a single condition */
+ if ((Size_t)key >= (Size_t)size) {
+ if (UNLIKELY(neg))
return NULL;
+ goto emptyness;
}
- if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
+ if (!AvARRAY(av)[key]) {
emptyness:
return lval ? av_store(av,key,newSV(0)) : NULL;
}
- if (AvREIFY(av)
- && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
- || SvIS_FREED(AvARRAY(av)[key]))) {
- AvARRAY(av)[key] = NULL; /* 1/2 reify */
- goto emptyness;
- }
return &AvARRAY(av)[key];
}
;;
esac
;;
- *) case "$opt" in
- -W)
- # -Wextra is the modern form of -W, so add
- # -W only if -Wextra is not there already.
- case " $warn " in
- *-Wextra*) ;;
- *)
- echo "cflags.SH: Adding $opt."
- warn="$warn $opt"
- ;;
- esac
- ;;
- -Werror=declaration-after-statement)
- # -pedantic* (with -std=c89) covers -Werror=d-a-s.
- case "$stdflags$warn" in
- *-std=c89*-pedantic*|*-pedantic*-std=c89*) ;;
- *)
- echo "cflags.SH: Adding $opt."
- warn="$warn $opt"
- ;;
- esac
- ;;
+ -W)
+ # -Wextra is the modern form of -W, so add
+ # -W only if -Wextra is not there already.
+ case " $warn " in
+ *-Wextra*) ;;
+ *)
+ echo "cflags.SH: Adding $opt."
+ warn="$warn $opt"
+ ;;
+ esac
+ ;;
+ -Werror=declaration-after-statement)
+ # -pedantic* (with -std=c89) covers -Werror=d-a-s.
+ case "$stdflags$warn" in
+ *-std=c89*-pedantic*|*-pedantic*-std=c89*) ;;
*)
echo "cflags.SH: Adding $opt."
warn="$warn $opt"
;;
esac
+ ;;
+ *)
+ echo "cflags.SH: Adding $opt."
+ warn="$warn $opt"
+ ;;
esac
fi
;;
* 37f6186253da9824bdb27f4ad867bfe8c25d4dc6bdb2f05585e40a034675a348 lib/unicore/extracted/DLineBreak.txt
* ef24061b5a5dc93d7e90c2e34530ec757180ee75d872cba65ffc946e52624ae8 lib/unicore/extracted/DNumType.txt
* a197371fec9a1b517058b440841f60f9378d81682084eef8db22a88cb2f96e90 lib/unicore/extracted/DNumValues.txt
- * 0cc006e22469cee3db1a55a4df1ac656c9d26a70ba920985883eb77198931c1a lib/unicore/mktables
+ * 5c7eb94310e2aaa15702fd6bed24ff0e7ab5448f9a8231d8c49ca96c9e941089 lib/unicore/mktables
* cdecb300baad839a6f62791229f551a4fa33f3cbdca08e378dc976466354e778 lib/unicore/version
* 913d2f93f3cb6cdf1664db888bf840bc4eb074eef824e082fceda24a9445e60c regen/charset_translations.pl
* 11011bc761487f5a63c8135e67248394d4cdff6f8f204a41cdfbdc8131e79406 regen/mk_invlists.pl
* LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE
* LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE
* LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE
+ * LONG_DOUBLE_IS_VAX_H_FLOAT
* LONG_DOUBLE_IS_UNKNOWN_FORMAT
* It is only defined if the system supports long doubles.
*/
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE 6
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE 7
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE 8
+#define LONG_DOUBLE_IS_VAX_H_FLOAT 9
#define LONG_DOUBLE_IS_UNKNOWN_FORMAT -1
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_LE /* back-compat */
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE /* back-compat */
*/
#$d_futimes HAS_FUTIMES /**/
+/* HAS_GAI_STRERROR:
+ * This symbol, if defined, indicates that the gai_strerror routine
+ * is available to translate error codes returned by getaddrinfo()
+ * into human readable strings.
+ */
+#$d_gai_strerror HAS_GAI_STRERROR /**/
+
/* HAS_GETADDRINFO:
* This symbol, if defined, indicates that the getaddrinfo() function
* is available for use.
* This symbol, if defined, indicates that the querylocale routine is
* available to return the name of the locale for a category mask.
*/
+/* I_XLOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <xlocale.h> to get uselocale() and its friends.
+ */
#$d_newlocale HAS_NEWLOCALE /**/
#$d_freelocale HAS_FREELOCALE /**/
#$d_uselocale HAS_USELOCALE /**/
#$d_querylocale HAS_QUERYLOCALE /**/
+#$i_xlocale I_XLOCALE /**/
/* HAS_NEXTAFTER:
* This symbol, if defined, indicates that the nextafter routine is
If you or somebody else will be maintaining perl at your site, please
fill in the correct e-mail address here so that they may be contacted
if necessary. Currently, the "perlbug" program included with perl
-will send mail to this address in addition to perlbug@perl.com. You may
+will send mail to this address in addition to perlbug@perl.org. You may
enter "none" for no administrator.
$ EOD
$ ENDIF
$ WC "i_varargs='undef'"
$ WC "i_varhdr='stdarg.h'"
$ WC "i_vfork='undef'"
+$ WC "i_xlocale='undef'"
$ WC "inc_version_list='0'"
$ WC "inc_version_list_init='0'"
$ WC "installarchlib='" + installarchlib + "'"
$ WC "d_endpwent_r='undef'"
$ WC "d_endservent_r='undef'"
$ WC "d_freelocale='undef'"
+$ WC "d_gai_strerror='undef'"
$ WC "d_getgrent_r='undef'"
$ WC "d_getgrgid_r='" + d_getgrgid_r + "'"
$ WC "d_getgrnam_r='" + d_getgrnam_r + "'"
#!/usr/bin/perl
use strict;
+BEGIN { pop @INC if $INC[-1] eq '.' }
use File::Find;
use Getopt::Std;
use Archive::Tar;
#!/usr/bin/perl
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use Archive::Tar;
use Getopt::Std;
# archive. See 'ptargrep --help' for more documentation.
#
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use warnings;
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "2.08";
+$VERSION = "2.10";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
BEGIN {
require Exporter;
- $VERSION = '2.08';
+ $VERSION = '2.10';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '2.08';
+$VERSION = '2.10';
### set value to 1 to oct() it during the unpack ###
--- /dev/null
+---
+abstract: ~
+author:
+ - 'Olivier Mengué'
+build_requires:
+ ExtUtils::MakeMaker: 6.36
+configure_requires:
+ ExtUtils::MakeMaker: 6.36
+distribution_type: module
+dynamic_config: 1
+generated_by: 'Module::Install version 1.06'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Foo
+no_index:
+ directory:
+ - inc
+requires:
+ perl: 5.005
+resources:
+ license: http://dev.perl.org/licenses/
+version: 0.01
--- /dev/null
+{
+ "abstract" : "Lexical Analyzer for Perl5",
+ "author" : [
+ "Masaaki Goshima (goccy) <goccy(at)cpan.org>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Module::Build version 0.4205",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Compiler-Lexer",
+ "no_index" : {
+ "directory" : [
+ "t",
+ "examples",
+ "builder"
+ ]
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "ExtUtils::CBuilder" : "0"
+ }
+ },
+ "configure" : {
+ "requires" : {
+ "Module::Build" : "0.38",
+ "Module::Build::XSUtil" : "0.06"
+ }
+ }
+ },
+ "provides" : {
+ "Compiler::Lexer" : {
+ "file" : "lib/Compiler/Lexer.pm",
+ "version" : "0.18"
+ },
+ "Compiler::Lexer::Kind" : {
+ "file" : "lib/Compiler/Lexer/Constants.pm"
+ },
+ "Compiler::Lexer::SyntaxType" : {
+ "file" : "lib/Compiler/Lexer/Constants.pm"
+ },
+ "Compiler::Lexer::Token" : {
+ "file" : "lib/Compiler/Lexer/Token.pm"
+ },
+ "Compiler::Lexer::TokenType" : {
+ "file" : "lib/Compiler/Lexer/Constants.pm"
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "web" : "https://github.com/goccy/p5-Compiler-Lexer/issues"
+ },
+ "homepage" : "https://github.com/goccy/p5-Compiler-Lexer",
+ "repository" : {
+ "type" : "git",
+ "url" : "git://github.com/goccy/p5-Compiler-Lexer.git"
+ }
+ },
+ "version" : "0.18",
+ "x_contributors" : [
+ "tokuhirom <tokuhirom@gmail.com>",
+ "Reini Urban <rurban@cpanel.net>",
+ "Fumihiro Itoh <fmhrit@gmail.com>",
+ "Masaaki Goshima <masaaki.goshima@mixi.co.jp>",
+ "moznion <moznion@gmail.com>",
+ "Olivier Mengué <dolmen@cpan.org>",
+ "Masaaki Goshima <goccy54@gmail.com>"
+ ]
+}
--- /dev/null
+{
+ "abstract" : "a set of version requirements for a CPAN dist",
+ "author" : [
+ "Ricardo Signes <rjbs@cpan.org>"
+ ],
+ "build_requires" : {
+ "Test::More" : "0.88"
+ },
+ "configure_requires" : {
+ "ExtUtils::MakeMaker" : "6.31"
+ },
+ "generated_by" : "Dist::Zilla version 2.100991",
+ "license" : "perl",
+ "meta-spec" : {
+ "url" : "http://module-build.sourceforge.net/META-spec-v1.4.html",
+ "version" : 1.4
+ },
+ "name" : "Version-Requirements",
+ "recommends" : {},
+ "requires" : {
+ "Carp" : "0",
+ "Scalar::Util" : "0",
+ "version" : "0.77"
+ },
+ "resources" : {
+ "repository" : "git://git.codesimply.com/Version-Requirements.git"
+ },
+ "version" : "0.101010",
+ "x_contributors" : [
+ "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>"
+ ]
+}
+
--- /dev/null
+---
+abstract: 'a set of version requirements for a CPAN dist'
+author:
+ - 'Ricardo Signes <rjbs@cpan.org>'
+build_requires:
+ Test::More: 0.88
+configure_requires:
+ ExtUtils::MakeMaker: 6.31
+generated_by: 'Dist::Zilla version 2.100991'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Version-Requirements
+recommends: {}
+requires:
+ Carp: 0
+ Scalar::Util: 0
+ version: 0.77
+resources:
+ repository: git://git.codesimply.com/Version-Requirements.git
+version: 0.101010
+x_contributors:
+ - 'Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>'
--- /dev/null
+abstract: 'a set of version requirements for a CPAN dist'
+author:
+ - 'Ricardo Signes <rjbs@cpan.org>'
+build_requires:
+ Test::More: 0.88
+configure_requires:
+ ExtUtils::MakeMaker: 6.31
+generated_by: 'Dist::Zilla version 2.100991'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Version-Requirements
+recommends: {}
+requires:
+ Carp: 0
+ Scalar::Util: 0
+ version: 0.77
+resources:
+ repository: git://git.codesimply.com/Version-Requirements.git
+version: 0.101010
+x_contributors:
+ - 'Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>'
--- /dev/null
+{
+ "abstract" : "a set of version requirements for a CPAN dist",
+ "author" : [
+ "Ricardo Signes <rjbs@cpan.org>"
+ ],
+ "build_requires" : {
+ "Test::More" : "0.88"
+ },
+ "configure_requires" : {
+ "ExtUtils::MakeMaker" : "6.31"
+ },
+ "generated_by" : "Dist::Zilla version 2.100991",
+ "license" : "perl",
+ "meta-spec" : {
+ "url" : "http://module-build.sourceforge.net/META-spec-v1.4.html",
+ "version" : 1.4
+ },
+ "name" : "Version-Requirements",
+ "recommends" : {},
+ "requires" : {
+ "Carp" : "0",
+ "Scalar::Util" : "0",
+ "version" : "0.77"
+ },
+ "resources" : {
+ "repository" : "git://git.codesimply.com/Version-Requirements.git"
+ },
+ "version" : "0.101010",
+ "x_contributors" : [
+ "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>"
+ ]
+}
+
--- /dev/null
+---
+abstract: 'a set of version requirements for a CPAN dist'
+author:
+ - 'Ricardo Signes <rjbs@cpan.org>'
+build_requires:
+ Test::More: 0.88
+configure_requires:
+ ExtUtils::MakeMaker: 6.31
+generated_by: 'Dist::Zilla version 2.100991'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Version-Requirements
+recommends: {}
+requires:
+ Carp: 0
+ Scalar::Util: 0
+ version: 0.77
+resources:
+ repository: git://git.codesimply.com/Version-Requirements.git
+version: 0.101010
+x_contributors:
+ - 'Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>'
use warnings;
package CPAN::Meta;
-our $VERSION = '2.150005';
+our $VERSION = '2.150010';
#pod =head1 SYNOPSIS
#pod
=head1 VERSION
-version 2.150005
+version 2.150010
=head1 SYNOPSIS
Ricardo Signes <rjbs@cpan.org>
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
=back
=head1 CONTRIBUTORS
-=for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern mohawk2 moznion Niko Tyni Olaf Alders Olivier Mengué Randy Sims Tomohiro Hosaka
+=for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Benjamin Noggle Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov David Golden Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Kent Fredric Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern Mohammad Anwar mohawk2 moznion Niko Tyni Olaf Alders Olivier Mengué Randy Sims Tomohiro Hosaka
=over 4
=item *
+Benjamin Noggle <agwind@users.noreply.github.com>
+
+=item *
+
Christopher J. Madsen <cjm@cpan.org>
=item *
=item *
+David Golden <xdg@xdg.me>
+
+=item *
+
Eric Wilhelm <ewilhelm@cpan.org>
=item *
=item *
+Kent Fredric <kentfredric@gmail.com>
+
+=item *
+
Ken Williams <kwilliams@cpan.org>
=item *
=item *
+Mohammad S Anwar <mohammad.anwar@yahoo.com>
+
+=item *
+
mohawk2 <mohawk2@users.noreply.github.com>
=item *
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
use warnings;
package CPAN::Meta::Converter;
-our $VERSION = '2.150005';
+our $VERSION = '2.150010';
#pod =head1 SYNOPSIS
#pod
# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
+# We limit cloning to a maximum depth to bail out on circular data
+# structures. While actual cycle detection might be technically better,
+# we expect circularity in META data structures to be rare and generally
+# the result of user error. Therefore, a depth counter is lower overhead.
+our $DCLONE_MAXDEPTH = 1024;
+our $_CLONE_DEPTH;
+
sub _dclone {
- my $ref = shift;
-
- # if an object is in the data structure and doesn't specify how to
- # turn itself into JSON, we just stringify the object. That does the
- # right thing for typical things that might be there, like version objects,
- # Path::Class objects, etc.
- no warnings 'once';
- no warnings 'redefine';
- local *UNIVERSAL::TO_JSON = sub { "$_[0]" };
-
- my $json = Parse::CPAN::Meta->json_backend()->new
- ->utf8
- ->allow_blessed
- ->convert_blessed;
- $json->decode($json->encode($ref))
+ my ( $ref ) = @_;
+ return $ref unless my $reftype = ref $ref;
+
+ local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH;
+ die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0;
+
+ return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype;
+ return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype;
+
+ if ( 'SCALAR' eq $reftype ) {
+ my $new = _dclone(${$ref});
+ return \$new;
+ }
+
+ # We can't know if TO_JSON gives us cloned data, so refs must recurse
+ if ( eval { $ref->can('TO_JSON') } ) {
+ my $data = $ref->TO_JSON;
+ return ref $data ? _dclone( $data ) : $data;
+ }
+
+ # Just stringify everything else
+ return "$ref";
}
my %known_specs = (
my ($element, $key, $meta, $version) = @_;
return unless $element;
- # cleanup wrong format
+ # clean up wrong format
if ( ! ref $element ) {
my $item = $element;
$element = { directory => [ $item ], file => [ $item ] };
}
elsif ( ref $element eq 'ARRAY' ) {
my $hashref = { map { $_ => 0 } @$element };
- return _version_map($hashref); # cleanup any weird stuff
+ return _version_map($hashref); # clean up any weird stuff
}
elsif ( ref $element eq '' && length $element ) {
return { $element => 0 }
=head1 VERSION
-version 2.150005
+version 2.150010
=head1 SYNOPSIS
Ricardo Signes <rjbs@cpan.org>
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
=back
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
use warnings;
package CPAN::Meta::Feature;
-our $VERSION = '2.150005';
+our $VERSION = '2.150010';
use CPAN::Meta::Prereqs;
=head1 VERSION
-version 2.150005
+version 2.150010
=head1 DESCRIPTION
Ricardo Signes <rjbs@cpan.org>
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
=back
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
use warnings;
package CPAN::Meta::History;
-our $VERSION = '2.150005';
+our $VERSION = '2.150010';
1;
=head1 VERSION
-version 2.150005
+version 2.150010
=head1 DESCRIPTION
Ricardo Signes <rjbs@cpan.org>
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
=back
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=item *
Include list of valid licenses from L<Module::Build> 0.17 rather than
-linking to the module.
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
=back
F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format. The
reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
-L<this thread|http://archive.develooper.com/makemaker@perl.org/msg00405.html>
+L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
on the MakeMaker mailing list.
-The first line of a F<META.yml> file should be a valid L<YAML document header|http://www.yaml.org/spec/#.Document>
+The first line of a F<META.yml> file should be a valid
+L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
like C<"--- #YAML:1.0">
=head1 Fields
The rest of the META.yml file is one big YAML
-L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->,
+L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
whose keys are described here.
=over 4
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.
+This is a dual license, in which the user may choose between either the GPL
+version 1 or the Artistic version 1 license.
=item gpl
-The distribution is distributed under the terms of the Gnu General Public
-License (L<http://www.opensource.org/licenses/gpl-license.php>).
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
-The distribution is distributed under the terms of the Gnu Lesser General
-Public License (L<http://www.opensource.org/licenses/lgpl-license.php>).
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
-The distribution is licensed under the Artistic License, as specified by the
-Artistic file in the standard perl distribution.
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
-The distribution is licensed under the BSD License
-(L<http://www.opensource.org/licenses/bsd-license.php>).
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
-L<www.opensource.org|http://www.opensource.org> but that allows distribution
+L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
Data::Dumper: 0
File::Find: 1.03
-A YAML L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution requires for proper
operation. The keys are the module names, and the values are version
-specifications as described in the L<Module::Build|documentation for Module::Build's "requires" parameter>.
+specifications as described in the
+L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.
I<Note: the exact nature of the fancy specifications like
C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
Data::Dumper: 0
File::Find: 1.03
-A YAML L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution recommends for enhanced
operation.
Data::Dumper: 0
File::Find: 1.03
-A YAML L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules required for building and/or testing of
this distribution. These dependencies are not required after the
module is installed.
Data::Dumper: 0
File::Find: 1.03
-A YAML L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules that cannot be installed while this
distribution is installed. This is a pretty uncommon situation.
Currently L<Module::Build> doesn't actually do anything with
this flag - it's probably going to be up to higher-level tools like
-L<CPAN|CPAN.pm> to do something useful with it. It can potentially
+L<CPAN.pm|CPAN> to do something useful with it. It can potentially
bring lots of security, packaging, and convenience improvements.
=item generated_by
=item *
Include list of valid licenses from L<Module::Build> 0.18 rather than
-linking to the module.
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
=back
F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format. The
reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
-L<this thread|http://archive.develooper.com/makemaker@perl.org/msg00405.html>
+L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
on the MakeMaker mailing list.
-The first line of a F<META.yml> file should be a valid L<YAML document header|http://www.yaml.org/spec/#.Document>
+The first line of a F<META.yml> file should be a valid
+L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
like C<"--- #YAML:1.0">
=head1 Fields
The rest of the META.yml file is one big YAML
-L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->,
+L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
whose keys are described here.
=over 4
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.
+This is a dual license, in which the user may choose between either the GPL
+version 1 or the Artistic version 1 license.
=item gpl
-The distribution is distributed under the terms of the Gnu General Public
-License (L<http://www.opensource.org/licenses/gpl-license.php>).
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
-The distribution is distributed under the terms of the Gnu Lesser General
-Public License (L<http://www.opensource.org/licenses/lgpl-license.php>).
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
-The distribution is licensed under the Artistic License, as specified by the
-Artistic file in the standard perl distribution.
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
-The distribution is licensed under the BSD License
-(L<http://www.opensource.org/licenses/bsd-license.php>).
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
-L<www.opensource.org|http://www.opensource.org> but that allows distribution
+L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
Data::Dumper: 0
File::Find: 1.03
-A YAML L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution requires for proper
operation. The keys are the module names, and the values are version
-specifications as described in the L<Module::Build|documentation for Module::Build's "requires" parameter>.
+specifications as described in the
+L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.
I<Note: the exact nature of the fancy specifications like
C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
Data::Dumper: 0
File::Find: 1.03
-A YAML L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution recommends for enhanced
operation.
Data::Dumper: 0
File::Find: 1.03
-A YAML L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules required for building and/or testing of
this distribution. These dependencies are not required after the
module is installed.
Data::Dumper: 0
File::Find: 1.03
-A YAML L<mapping|http://www.yaml.org/spec/#.-syntax-mapping-Mapping->
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules that cannot be installed while this
distribution is installed. This is a pretty uncommon situation.
Currently L<Module::Build> doesn't actually do anything with
this flag - it's probably going to be up to higher-level tools like
-L<CPAN|CPAN.pm> to do something useful with it. It can potentially
+L<CPAN.pm|CPAN> to do something useful with it. It can potentially
bring lots of security, packaging, and convenience improvements.
=item generated_by
=item *
Include list of valid licenses from L<Module::Build> 0.2611 rather than
-linking to the module.
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
=back
=item *
-Module::Build design plans
-
-L<http://nntp.x.perl.org/group/perl.makemaker/406>
+L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
=item *
-Not keen on YAML
-
-L<http://nntp.x.perl.org/group/perl.module-authors/1353>
+L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
=item *
-META Concerns
-
-L<http://nntp.x.perl.org/group/perl.module-authors/1385>
+L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=head1 VERSION SPECIFICATIONS
-Some fields require a version specification (ex. L<"requires">,
-L<"recommends">, L<"build_requires">, etc.). This section details the
+Some fields require a version specification (ex. L</requires>,
+L</recommends>, L</build_requires>, etc.). This section details the
version specifications that are currently supported.
If a single version is listed, then that version is considered to be
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.
+This is a dual license, in which the user may choose between either the GPL
+version 1 or the Artistic version 1 license.
=item gpl
-The distribution is distributed under the terms of the Gnu General Public
-License (L<http://www.opensource.org/licenses/gpl-license.php>).
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
-The distribution is distributed under the terms of the Gnu Lesser General
-Public License (L<http://www.opensource.org/licenses/lgpl-license.php>).
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
-The distribution is licensed under the Artistic License, as specified by the
-Artistic file in the standard perl distribution.
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
-The distribution is licensed under the BSD License
-(L<http://www.opensource.org/licenses/bsd-license.php>).
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
-L<www.opensource.org|http://www.opensource.org> but that allows distribution
+L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
which are made available when its requirements are met. For each
-feature a description is provided along with any of L<"requires">,
-L<"build_requires">, L<"conflicts">, L<"requires_packages">,
-L<"requires_os">, and L<"excludes_os"> which have the same meaning in
+feature a description is provided along with any of L</requires>,
+L</build_requires>, L</conflicts>, C<requires_packages>,
+C<requires_os>, and C<excludes_os> which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
-L</"no_index">. See below.
+L</no_index>. See below.
=head2 provides
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
-When using tools like C<Module::Build> that can generate the
+When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
=head1 SEE ALSO
-CPAN, L<http://www.cpan.org/>
+L<CPAN|http://www.cpan.org/>
-CPAN.pm, L<http://search.cpan.org/author/ANDK/CPAN/>
+L<CPAN.pm|CPAN>
-CPANPLUS, L<http://search.cpan.org/author/KANE/CPANPLUS/>
+L<CPANPLUS>
-Data::Dumper, L<http://search.cpan.org/author/ILYAM/Data-Dumper/>
+L<Data::Dumper>
-ExtUtils::MakeMaker, L<http://search.cpan.org/author/MSCHWERN/ExtUtils-MakeMaker/>
+L<ExtUtils::MakeMaker>
-Module::Build, L<http://search.cpan.org/author/KWILLIAMS/Module-Build/>
+L<Module::Build>
-Module::Install, L<http://search.cpan.org/author/KWILLIAMS/Module-Install/>
+L<Module::Install>
-XML, L<http://www.w3.org/XML/>
+L<XML|http://www.w3.org/XML/>
-YAML, L<http://www.yaml.org/>
+L<YAML|http://www.yaml.org/>
=head1 HISTORY
=item *
-Added the L</"dynamic_config"> field, which was missing from the initial
+Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item *
-Added and deprecated the L<"private"> field.
+Added and deprecated the L</private> field.
=item *
-Added L<"abstract">, L<"configure">, L<"requires_packages">,
-L<"requires_os">, L<"excludes_os">, and L<"no_index"> fields.
+Added L</abstract>, C<configure>, C<requires_packages>,
+C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
=item *
-Added L<"generation">, L<"authored_by"> fields.
+Added C<generation>, C<authored_by> fields.
=item *
-Add alternative proposal to the L<"recommends"> field.
+Add alternative proposal to the L</recommends> field.
=item *
-Add proposal for a L<"requires_build_tools"> field.
+Add proposal for a C<requires_build_tools> field.
=back
=item *
-Added section L<"VERSION SPECIFICATIONS">.
+Added section L</"VERSION SPECIFICATIONS">.
=item *
=item *
-Add proposal for L<"auto_regenerate"> field.
+Add proposal for C<auto_regenerate> field.
=back
=item *
-Add L<"index"> field as a compliment to L<"no_index">
+Add C<index> field as a compliment to L</no_index>
=item *
-Add L<"keywords"> field as a means to aid searching distributions.
+Add L</keywords> field as a means to aid searching distributions.
=item *
-Add L<"TERMINOLOGY"> section to explain certain terms that may be
+Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item *
-Changed C<authored_by> to C<author>, since that's always been what
+Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
=item *
-Noted that the C<distribution_type> field is basically meaningless,
+Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
-Clarified C<dynamic_config> a bit.
+Clarified L</dynamic_config> a bit.
=back
=item *
Include list of valid licenses from L<Module::Build> 0.2805 rather than
-linking to the module.
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
=back
=over 4
-=item Module::Build design plans
+=item *
-L<http://nntp.x.perl.org/group/perl.makemaker/406>
+L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
-=item Not keen on YAML
+=item *
-L<http://nntp.x.perl.org/group/perl.module-authors/1353>
+L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
-=item META Concerns
+=item *
-L<http://nntp.x.perl.org/group/perl.module-authors/1385>
+L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=item apache
-The distribution is licensed under the Apache Software License
-(L<http://opensource.org/licenses/apachepl.php>).
+The distribution is licensed under the Apache Software License version 1.1
+(L<http://opensource.org/licenses/Apache-1.1>).
=item artistic
-The distribution is licensed under the Artistic License, as specified by the
-Artistic file in the standard perl distribution.
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
-The distribution is licensed under the BSD License
-(L<http://www.opensource.org/licenses/bsd-license.php>).
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
=item gpl
-The distribution is licensed under the terms of the Gnu General Public License
-(L<http://www.opensource.org/licenses/gpl-license.php>).
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=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>).
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item mit
The distribution is licensed under the MIT License
-(L<http://opensource.org/licenses/mit-license.php>).
+(L<http://opensource.org/licenses/MIT>).
=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>)
+(L<http://opensource.org/licenses/MPL-1.0> or
+L<http://opensource.org/licenses/MPL-1.1>)
=item open_source
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.
+This is a dual license, in which the user may choose between either the GPL
+version 1 or the Artistic version 1 license.
=item restrictive
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution requires for proper operation. The keys are the module
names, and the values are version specifications as described in
-L<VERSION SPECIFICATIONS>.
+L</"VERSION SPECIFICATIONS">.
=head2 recommends
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
this distribution recommends for enhanced operation. The keys are the
module names, and the values are version specifications as described
-in L<VERSION SPECIFICATIONS>.
+in L</"VERSION SPECIFICATIONS">.
I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
which are made available when its requirements are met. For each
-feature a description is provided along with any of L<"requires">,
-L<"build_requires">, L<"conflicts">, L<"requires_packages">,
-L<"requires_os">, and L<"excludes_os"> which have the same meaning in
+feature a description is provided along with any of L</requires>,
+L</build_requires>, L</conflicts>, C<requires_packages>,
+C<requires_os>, and C<excludes_os> which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
required for building and/or testing of this distribution. The keys
are the module names, and the values are version specifications as
-described in L<VERSION SPECIFICATIONS>. These dependencies are not
+described in L</"VERSION SPECIFICATIONS">. These dependencies are not
required after the module is installed.
=head2 conflicts
cannot be installed while this distribution is installed. This is a
pretty uncommon situation. The keys for C<conflicts> are the module
names, and the values are version specifications as described in
-L<VERSION SPECIFICATIONS>.
+L</"VERSION SPECIFICATIONS">.
=head2 dynamic_config
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
-L</"no_index">. See below.
+L</no_index>. See below.
=head2 provides
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
-When using tools like C<Module::Build> that can generate the
+When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
and indexing tools. This is useful when no C<provides> field is
present.
-For example, C<search.cpan.org> excludes items listed in C<no_index>
+For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
when searching for POD, meaning files in these directories will not
converted to HTML and made public - which is useful if you have
example or test PODs that you don't want the search engine to go
=head1 VERSION SPECIFICATIONS
-Some fields require a version specification (ex. L<"requires">,
-L<"recommends">, L<"build_requires">, etc.) to indicate the particular
+Some fields require a version specification (ex. L</requires>,
+L</recommends>, L</build_requires>, etc.) to indicate the particular
versionZ<>(s) of some other module that may be required as a
prerequisite. This section details the version specification formats
that are currently supported.
=head1 SEE ALSO
-CPAN, L<http://www.cpan.org/>
+L<CPAN|http://www.cpan.org/>
-CPAN.pm, L<http://search.cpan.org/dist/CPAN/>
+L<CPAN.pm|CPAN>
-CPANPLUS, L<http://search.cpan.org/dist/CPANPLUS/>
+L<CPANPLUS>
-Data::Dumper, L<http://search.cpan.org/dist/Data-Dumper/>
+L<Data::Dumper>
-ExtUtils::MakeMaker, L<http://search.cpan.org/dist/ExtUtils-MakeMaker/>
+L<ExtUtils::MakeMaker>
-Module::Build, L<http://search.cpan.org/dist/Module-Build/>
+L<Module::Build>
-Module::Install, L<http://search.cpan.org/dist/Module-Install/>
+L<Module::Install>
-XML, L<http://www.w3.org/XML/>
+L<XML|http://www.w3.org/XML/>
-YAML, L<http://www.yaml.org/>
+L<YAML|http://www.yaml.org/>
=head1 HISTORY
=item *
-Added the L</"dynamic_config"> field, which was missing from the initial
+Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item *
-Added and deprecated the L<"private"> field.
+Added and deprecated the L</private> field.
=item *
-Added L<"abstract">, L<"configure">, L<"requires_packages">,
-L<"requires_os">, L<"excludes_os">, and L<"no_index"> fields.
+Added L</abstract>, C<configure>, C<requires_packages>,
+C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
=item *
-Added L<"generation">, L<"authored_by"> fields.
+Added C<generation>, C<authored_by> fields.
=item *
-Add alternative proposal to the L<"recommends"> field.
+Add alternative proposal to the L</recommends> field.
=item *
-Add proposal for a L<"requires_build_tools"> field.
+Add proposal for a C<requires_build_tools> field.
=back
=item *
-Added section L<"VERSION SPECIFICATIONS">.
+Added section L</"VERSION SPECIFICATIONS">.
=item *
=item *
-Add proposal for L<"auto_regenerate"> field.
+Add proposal for C<auto_regenerate> field.
=back
=item *
-Add L<"index"> field as a compliment to L<"no_index">
+Add C<index> field as a compliment to L</no_index>
=item *
-Add L<"keywords"> field as a means to aid searching distributions.
+Add L</keywords> field as a means to aid searching distributions.
=item *
-Add L<"TERMINOLOGY"> section to explain certain terms that may be
+Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item *
-Changed C<authored_by> to C<author>, since that's always been what
+Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
=item *
-Noted that the C<distribution_type> field is basically meaningless,
+Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
-Clarified C<dynamic_config> a bit.
+Clarified L</dynamic_config> a bit.
=back
=item *
Include list of valid licenses from L<Module::Build> 0.2807 rather than
-linking to the module.
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
=back
won't make it into the stable version) can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>
-=begin MAINTAINER
-
-The master source for the META spec is META-spec.pod. META-spec.html
-is built (manually) from META-spec.pod whenever there are changes, and
-the two files should generally be checked in together. Ideally it
-would happen through a trigger or something, but it doesn't.
-
-Ken has a cron job that copies the latest bleeding-edge version of the
-spec (HTML version) to Sourceforge whenever his laptop is turned on:
-
- 21 * * * * svn cat http://svn.perl.org/modules/Module-Build/trunk/website/META-spec.html \
- | ssh kwilliams@shell.sourceforge.net \
- 'cat > /home/groups/m/mo/module-build/htdocs/META-spec-blead.html'
-
-The numbered revisions of the spec at
-L<"http://module-build.sourceforge.net/"> are captures of the spec at
-opportune moments. A couple of symlinks also exist for convenience:
-
- -rw-r--r-- 1 kwilliams 24585 Oct 10 17:21 META-spec-blead.html
- lrwxrwxrwx 1 kwilliams 19 Jan 19 2007 META-spec-current.html -> META-spec-v1.3.html
- lrwxrwxrwx 1 kwilliams 22 Jan 19 2007 META-spec.html -> META-spec-current.html
- -rw-r--r-- 1 kwilliams 5830 Jul 25 2005 META-spec-v1.0.html
- -rw-r--r-- 1 kwilliams 7847 Jul 25 2005 META-spec-v1.1.html
- -rw-r--r-- 1 kwilliams 22635 Aug 23 2005 META-spec-v1.2.html
- -rw-r--r-- 1 kwilliams 24086 Nov 4 2006 META-spec-v1.3.html
-
-=end MAINTAINER
-
-
=head1 FORMAT
F<META.yml> files are written in the YAML format (see
=over 4
-=item Module::Build design plans
+=item *
-L<http://nntp.x.perl.org/group/perl.makemaker/406>
+L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
-=item Not keen on YAML
+=item *
-L<http://nntp.x.perl.org/group/perl.module-authors/1353>
+L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
-=item META Concerns
+=item *
-L<http://nntp.x.perl.org/group/perl.module-authors/1385>
+L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=item apache
-The distribution is licensed under the Apache Software License
-(L<http://opensource.org/licenses/apachepl.php>).
+The distribution is licensed under the Apache Software License version 1.1
+(L<http://opensource.org/licenses/Apache-1.1>).
=item artistic
-The distribution is licensed under the Artistic License, as specified by the
-Artistic file in the standard perl distribution.
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
-The distribution is licensed under the BSD License
-(L<http://www.opensource.org/licenses/bsd-license.php>).
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
=item gpl
-The distribution is licensed under the terms of the Gnu General Public License
-(L<http://www.opensource.org/licenses/gpl-license.php>).
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=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>).
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item mit
The distribution is licensed under the MIT License
-(L<http://opensource.org/licenses/mit-license.php>).
+(L<http://opensource.org/licenses/MIT>).
=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>)
+(L<http://opensource.org/licenses/MPL-1.0> or
+L<http://opensource.org/licenses/MPL-1.1>)
=item open_source
I<(Spec 1.1) [optional] {map} A YAML mapping of names for optional features
which are made available when its requirements are met. For each
-feature a description is provided along with any of L<"requires">,
-L<"build_requires">, and L<"conflicts">, which have the same meaning in
+feature a description is provided along with any of L</requires>,
+L</build_requires>, and L</conflicts>, which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
prerequisites required for building and/or testing of this
distribution. The keys are the names of the prerequisites (module
names or 'perl'), and the values are version specifications as
-described in L<VERSION SPECIFICATIONS>. These dependencies are not
+described in L</"VERSION SPECIFICATIONS">. These dependencies are not
required after the distribution is installed.
=head2 configure_requires
(Spec 1.4) [optional] {map} A YAML mapping indicating the Perl prerequisites
required before configuring this distribution. The keys are the
-names of the prerequisites (module names or 'perl'), and the values are version specifications as described
-in L<VERSION SPECIFICATIONS>. These dependencies are not required
-after the distribution is installed.
+names of the prerequisites (module names or 'perl'), and the values are version
+specifications as described in L</"VERSION SPECIFICATIONS">. These
+dependencies are not required after the distribution is installed.
=head2 conflicts
cannot be installed while this distribution is installed. This is a
pretty uncommon situation. The keys for C<conflicts> are the item
names (module names or 'perl'), and the values are version
-specifications as described in L<VERSION SPECIFICATIONS>.
+specifications as described in L</"VERSION SPECIFICATIONS">.
=head2 dynamic_config
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
-L</"no_index">. See below.
+L</no_index>. See below.
=head2 provides
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
-When using tools like C<Module::Build> that can generate the
+When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
and indexing tools. This is useful when no C<provides> field is
present.
-For example, C<search.cpan.org> excludes items listed in C<no_index>
+For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
when searching for POD, meaning files in these directories will not
converted to HTML and made public - which is useful if you have
example or test PODs that you don't want the search engine to go
=head1 VERSION SPECIFICATIONS
-Some fields require a version specification (ex. L<"requires">,
-L<"recommends">, L<"build_requires">, etc.) to indicate the particular
+Some fields require a version specification (ex. L</requires>,
+L</recommends>, L</build_requires>, etc.) to indicate the particular
versionZ<>(s) of some other module that may be required as a
prerequisite. This section details the version specification formats
that are currently supported.
=head1 SEE ALSO
-CPAN, L<http://www.cpan.org/>
+L<CPAN|http://www.cpan.org/>
-CPAN.pm, L<http://search.cpan.org/dist/CPAN/>
+L<CPAN.pm|CPAN>
-CPANPLUS, L<http://search.cpan.org/dist/CPANPLUS/>
+L<CPANPLUS>
-Data::Dumper, L<http://search.cpan.org/dist/Data-Dumper/>
+L<Data::Dumper>
-ExtUtils::MakeMaker, L<http://search.cpan.org/dist/ExtUtils-MakeMaker/>
+L<ExtUtils::MakeMaker>
-Module::Build, L<http://search.cpan.org/dist/Module-Build/>
+L<Module::Build>
-Module::Install, L<http://search.cpan.org/dist/Module-Install/>
+L<Module::Install>
-XML, L<http://www.w3.org/XML/>
+L<XML|http://www.w3.org/XML/>
-YAML, L<http://www.yaml.org/>
+L<YAML|http://www.yaml.org/>
=head1 HISTORY
=item *
-Added the L</"dynamic_config"> field, which was missing from the initial
+Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item *
-Added and deprecated the L<"private"> field.
+Added and deprecated the L</private> field.
=item *
-Added L<"abstract">, L<"configure">, L<"requires_packages">,
-L<"requires_os">, L<"excludes_os">, and L<"no_index"> fields.
+Added L</abstract>, C<configure>, C<requires_packages>,
+C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
=item *
-Added L<"generation">, L<"authored_by"> fields.
+Added C<generation>, C<authored_by> fields.
=item *
-Add alternative proposal to the L<"recommends"> field.
+Add alternative proposal to the L</recommends> field.
=item *
-Add proposal for a L<"requires_build_tools"> field.
+Add proposal for a C<requires_build_tools> field.
=back
=item *
-Added section L<"VERSION SPECIFICATIONS">.
+Added section L</"VERSION SPECIFICATIONS">.
=item *
=item *
-Add proposal for L<"auto_regenerate"> field.
+Add proposal for C<auto_regenerate> field.
=back
=item *
-Add L<"index"> field as a compliment to L<"no_index">
+Add C<index> field as a compliment to L</no_index>
=item *
-Add L<"keywords"> field as a means to aid searching distributions.
+Add L</keywords> field as a means to aid searching distributions.
=item *
-Add L<"TERMINOLOGY"> section to explain certain terms that may be
+Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item *
-Changed C<authored_by> to C<author>, since that's always been what
+Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
=item *
-Noted that the C<distribution_type> field is basically meaningless,
+Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
-Clarified C<dynamic_config> a bit.
+Clarified L</dynamic_config> a bit.
=back
=item *
-Added C<configure_requires>.
+Added L</configure_requires>.
=back
package CPAN::Meta::Merge;
-our $VERSION = '2.150005';
+our $VERSION = '2.150010';
use Carp qw/croak/;
use Scalar::Util qw/blessed/;
return $left;
}
-sub _improvize {
+sub _improvise {
my ($left, $right, $path) = @_;
my ($name) = reverse @{$path};
if ($name =~ /^x_/) {
homepage => \&_identical,
bugtracker => \&_uniq_map,
repository => \&_uniq_map,
- ':default' => \&_improvize,
+ ':default' => \&_improvise,
},
- ':default' => \&_improvize,
+ ':default' => \&_improvise,
);
sub new {
set_addition => \&_set_addition,
uniq_map => \&_uniq_map,
identical => \&_identical,
- improvize => \&_improvize,
+ improvise => \&_improvise,
+ improvize => \&_improvise, # [sic] for backwards compatibility
);
sub _coerce_mapping {
=head1 VERSION
-version 2.150005
+version 2.150010
=head1 SYNOPSIS
used for the merge. It can optionally take an C<extra_mappings> argument
that allows one to add additional merging functions for specific elements.
+The C<extra_mappings> arguments takes a hash ref with the same type of
+structure as described in L<CPAN::Meta::Spec>, except with its values as
+one of the L<defined merge strategies|/"MERGE STRATEGIES"> or a code ref
+to a merging function.
+
+ my $merger = CPAN::Meta::Merge->new(
+ default_version => '2',
+ extra_mappings => {
+ 'optional_features' => \&custom_merge_function,
+ 'x_custom' => 'set_addition',
+ 'x_meta_meta' => {
+ name => 'identical',
+ tags => 'set_addition',
+ }
+ }
+ );
+
=head2 merge(@fragments)
Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
(possibly incomplete) hashrefs of metadata.
+=head1 MERGE STRATEGIES
+
+C<merge> uses various strategies to combine different elements of the CPAN::Meta objects. The following strategies can be used with the extra_mappings argument of C<new>:
+
+=over
+
+=item identical
+
+The elements must be identical
+
+=item set_addition
+
+The union of two array refs
+
+ [ a, b ] U [ a, c] = [ a, b, c ]
+
+=item uniq_map
+
+Key value pairs from the right hash are merged to the left hash. Key
+collisions are only allowed if their values are the same. This merge
+function will recurse into nested hash refs following the same merge
+rules.
+
+=item improvise
+
+This merge strategy will try to pick the appropriate predefined strategy
+based on what element type. Array refs will try to use the
+C<set_addition> strategy, Hash refs will try to use the C<uniq_map>
+strategy, and everything else will try the C<identical> strategy.
+
+=back
+
=head1 AUTHORS
=over 4
Ricardo Signes <rjbs@cpan.org>
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
=back
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
use warnings;
package CPAN::Meta::Prereqs;
-our $VERSION = '2.150005';
+our $VERSION = '2.150010';
#pod =head1 DESCRIPTION
#pod
#pod
#pod =cut
+# note we also accept anything matching /\Ax_/i
sub __legal_phases { qw(configure build test runtime develop) }
sub __legal_types { qw(requires recommends suggests conflicts) }
return $req;
}
+#pod =method phases
+#pod
+#pod my @phases = $prereqs->phases;
+#pod
+#pod This method returns the list of all phases currently populated in the prereqs
+#pod object, suitable for iterating.
+#pod
+#pod =cut
+
+sub phases {
+ my ($self) = @_;
+
+ my %is_legal_phase = map {; $_ => 1 } $self->__legal_phases;
+ grep { /\Ax_/i or $is_legal_phase{$_} } keys %{ $self->{prereqs} };
+}
+
+#pod =method types_in
+#pod
+#pod my @runtime_types = $prereqs->types_in('runtime');
+#pod
+#pod This method returns the list of all types currently populated in the prereqs
+#pod object for the provided phase, suitable for iterating.
+#pod
+#pod =cut
+
+sub types_in {
+ my ($self, $phase) = @_;
+
+ return unless $phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases;
+
+ my %is_legal_type = map {; $_ => 1 } $self->__legal_types;
+ grep { /\Ax_/i or $is_legal_type{$_} } keys %{ $self->{prereqs}{$phase} };
+}
+
#pod =method with_merged_prereqs
#pod
#pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
my %new_arg;
- for my $phase ($self->__legal_phases) {
- for my $type ($self->__legal_types) {
+ for my $phase (__uniq(map { $_->phases } @prereq_objs)) {
+ for my $type (__uniq(map { $_->types_in($phase) } @prereq_objs)) {
+
my $req = CPAN::Meta::Requirements->new;
for my $prereq (@prereq_objs) {
my %hash;
- for my $phase ($self->__legal_phases) {
- for my $type ($self->__legal_types) {
+ for my $phase ($self->phases) {
+ for my $type ($self->types_in($phase)) {
my $req = $self->requirements_for($phase, $type);
next unless $req->required_modules;
my $clone = (ref $self)->new( $self->as_string_hash );
}
+sub __uniq {
+ my (%s, $u);
+ grep { defined($_) ? !$s{$_}++ : !$u++ } @_;
+}
+
1;
# ABSTRACT: a set of distribution prerequisites by phase and type
=head1 VERSION
-version 2.150005
+version 2.150010
=head1 DESCRIPTION
If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
be raised.
+=head2 phases
+
+ my @phases = $prereqs->phases;
+
+This method returns the list of all phases currently populated in the prereqs
+object, suitable for iterating.
+
+=head2 types_in
+
+ my @runtime_types = $prereqs->types_in('runtime');
+
+This method returns the list of all types currently populated in the prereqs
+object for the provided phase, suitable for iterating.
+
=head2 with_merged_prereqs
my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
Ricardo Signes <rjbs@cpan.org>
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
=back
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
use warnings;
package CPAN::Meta::Spec;
-our $VERSION = '2.150005';
+our $VERSION = '2.150010';
1;
=head1 VERSION
-version 2.150005
+version 2.150010
=head1 SYNOPSIS
=head2 Boolean
A I<Boolean> is used to provide a true or false value. It B<must> be
-represented as a defined value.
+represented as a defined value that is either "1" or "0" or stringifies
+to those values.
=head2 String
L<Module::Install>
+=item *
+
+L<CPAN::Meta::History::Meta_1_4>
+
=back
=head1 HISTORY
Ricardo Signes <rjbs@cpan.org>
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
=back
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
use warnings;
package CPAN::Meta::Validator;
-our $VERSION = '2.150005';
+our $VERSION = '2.150010';
#pod =head1 SYNOPSIS
#pod
#pod
#pod boolean($self,$key,$value)
#pod
-#pod Validates for a boolean value. Currently these values are '1', '0', 'true',
-#pod 'false', however the latter 2 may be removed.
+#pod Validates for a boolean value: a defined value that is either "1" or "0" or
+#pod stringifies to those values.
#pod
#pod =item *
#pod
sub boolean {
my ($self,$key,$value) = @_;
if(defined $value) {
- return 1 if($value =~ /^(0|1|true|false)$/);
+ return 1 if($value =~ /^(0|1)$/);
} else {
$value = '<undef>';
}
=head1 VERSION
-version 2.150005
+version 2.150010
=head1 SYNOPSIS
boolean($self,$key,$value)
-Validates for a boolean value. Currently these values are '1', '0', 'true',
-'false', however the latter 2 may be removed.
+Validates for a boolean value: a defined value that is either "1" or "0" or
+stringifies to those values.
=item *
Ricardo Signes <rjbs@cpan.org>
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
=back
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+package Parse::CPAN::Meta;
+# ABSTRACT: Parse META.yml and META.json CPAN metadata files
+
+our $VERSION = '2.150010';
+
+use Exporter;
+use Carp 'croak';
+
+our @ISA = qw/Exporter/;
+our @EXPORT_OK = qw/Load LoadFile/;
+
+sub load_file {
+ my ($class, $filename) = @_;
+
+ my $meta = _slurp($filename);
+
+ if ($filename =~ /\.ya?ml$/) {
+ return $class->load_yaml_string($meta);
+ }
+ elsif ($filename =~ /\.json$/) {
+ return $class->load_json_string($meta);
+ }
+ else {
+ $class->load_string($meta); # try to detect yaml/json
+ }
+}
+
+sub load_string {
+ my ($class, $string) = @_;
+ if ( $string =~ /^---/ ) { # looks like YAML
+ return $class->load_yaml_string($string);
+ }
+ elsif ( $string =~ /^\s*\{/ ) { # looks like JSON
+ return $class->load_json_string($string);
+ }
+ else { # maybe doc-marker-free YAML
+ return $class->load_yaml_string($string);
+ }
+}
+
+sub load_yaml_string {
+ my ($class, $string) = @_;
+ my $backend = $class->yaml_backend();
+ my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
+ croak $@ if $@;
+ return $data || {}; # in case document was valid but empty
+}
+
+sub load_json_string {
+ my ($class, $string) = @_;
+ require Encode;
+ # load_json_string takes characters, decode_json expects bytes
+ my $encoded = Encode::encode('UTF-8', $string, Encode::PERLQQ());
+ my $data = eval { $class->json_decoder()->can('decode_json')->($encoded) };
+ croak $@ if $@;
+ return $data || {};
+}
+
+sub yaml_backend {
+ if ($ENV{PERL_CORE} or not defined $ENV{PERL_YAML_BACKEND} ) {
+ _can_load( 'CPAN::Meta::YAML', 0.011 )
+ or croak "CPAN::Meta::YAML 0.011 is not available\n";
+ return "CPAN::Meta::YAML";
+ }
+ else {
+ my $backend = $ENV{PERL_YAML_BACKEND};
+ _can_load( $backend )
+ or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
+ $backend->can("Load")
+ or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
+ return $backend;
+ }
+}
+
+sub json_decoder {
+ if ($ENV{PERL_CORE}) {
+ _can_load( 'JSON::PP' => 2.27300 )
+ or croak "JSON::PP 2.27300 is not available\n";
+ return 'JSON::PP';
+ }
+ if (my $decoder = $ENV{CPAN_META_JSON_DECODER}) {
+ _can_load( $decoder )
+ or croak "Could not load CPAN_META_JSON_DECODER '$decoder'\n";
+ $decoder->can('decode_json')
+ or croak "No decode_json sub provided by CPAN_META_JSON_DECODER '$decoder'\n";
+ return $decoder;
+ }
+ return $_[0]->json_backend;
+}
+
+sub json_backend {
+ if ($ENV{PERL_CORE}) {
+ _can_load( 'JSON::PP' => 2.27300 )
+ or croak "JSON::PP 2.27300 is not available\n";
+ return 'JSON::PP';
+ }
+ if (my $backend = $ENV{CPAN_META_JSON_BACKEND}) {
+ _can_load( $backend )
+ or croak "Could not load CPAN_META_JSON_BACKEND '$backend'\n";
+ $backend->can('new')
+ or croak "No constructor provided by CPAN_META_JSON_BACKEND '$backend'\n";
+ return $backend;
+ }
+ if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
+ _can_load( 'JSON::PP' => 2.27300 )
+ or croak "JSON::PP 2.27300 is not available\n";
+ return 'JSON::PP';
+ }
+ else {
+ _can_load( 'JSON' => 2.5 )
+ or croak "JSON 2.5 is required for " .
+ "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
+ return "JSON";
+ }
+}
+
+sub _slurp {
+ require Encode;
+ open my $fh, "<:raw", "$_[0]" ## no critic
+ or die "can't open $_[0] for reading: $!";
+ my $content = do { local $/; <$fh> };
+ $content = Encode::decode('UTF-8', $content, Encode::PERLQQ());
+ return $content;
+}
+
+sub _can_load {
+ my ($module, $version) = @_;
+ (my $file = $module) =~ s{::}{/}g;
+ $file .= ".pm";
+ return 1 if $INC{$file};
+ return 0 if exists $INC{$file}; # prior load failed
+ eval { require $file; 1 }
+ or return 0;
+ if ( defined $version ) {
+ eval { $module->VERSION($version); 1 }
+ or return 0;
+ }
+ return 1;
+}
+
+# Kept for backwards compatibility only
+# Create an object from a file
+sub LoadFile ($) { ## no critic
+ return Load(_slurp(shift));
+}
+
+# Parse a document from a string.
+sub Load ($) { ## no critic
+ require CPAN::Meta::YAML;
+ my $object = eval { CPAN::Meta::YAML::Load(shift) };
+ croak $@ if $@;
+ return $object;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 SYNOPSIS
+
+ #############################################
+ # In your file
+
+ ---
+ name: My-Distribution
+ version: 1.23
+ resources:
+ homepage: "http://example.com/dist/My-Distribution"
+
+
+ #############################################
+ # In your program
+
+ use Parse::CPAN::Meta;
+
+ my $distmeta = Parse::CPAN::Meta->load_file('META.yml');
+
+ # Reading properties
+ my $name = $distmeta->{name};
+ my $version = $distmeta->{version};
+ my $homepage = $distmeta->{resources}{homepage};
+
+=head1 DESCRIPTION
+
+B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
+L<JSON::PP> and/or L<CPAN::Meta::YAML>.
+
+B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
+and C<load_yaml_string>. These will read and deserialize CPAN metafiles, and
+are described below in detail.
+
+B<Parse::CPAN::Meta> provides a legacy API of only two functions,
+based on the YAML functions of the same name. Wherever possible,
+identical calling semantics are used. These may only be used with YAML sources.
+
+All error reporting is done with exceptions (die'ing).
+
+Note that META files are expected to be in UTF-8 encoding, only. When
+converted string data, it must first be decoded from UTF-8.
+
+=begin Pod::Coverage
+
+
+
+
+=end Pod::Coverage
+
+=head1 METHODS
+
+=head2 load_file
+
+ my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');
+
+ my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');
+
+This method will read the named file and deserialize it to a data structure,
+determining whether it should be JSON or YAML based on the filename.
+The file will be read using the ":utf8" IO layer.
+
+=head2 load_yaml_string
+
+ my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);
+
+This method deserializes the given string of YAML and returns the first
+document in it. (CPAN metadata files should always have only one document.)
+If the source was UTF-8 encoded, the string must be decoded before calling
+C<load_yaml_string>.
+
+=head2 load_json_string
+
+ my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);
+
+This method deserializes the given string of JSON and the result.
+If the source was UTF-8 encoded, the string must be decoded before calling
+C<load_json_string>.
+
+=head2 load_string
+
+ my $metadata_structure = Parse::CPAN::Meta->load_string($some_string);
+
+If you don't know whether a string contains YAML or JSON data, this method
+will use some heuristics and guess. If it can't tell, it assumes YAML.
+
+=head2 yaml_backend
+
+ my $backend = Parse::CPAN::Meta->yaml_backend;
+
+Returns the module name of the YAML serializer. See L</ENVIRONMENT>
+for details.
+
+=head2 json_backend
+
+ my $backend = Parse::CPAN::Meta->json_backend;
+
+Returns the module name of the JSON serializer. If C<CPAN_META_JSON_BACKEND>
+is set, this will be whatever that's set to. If not, this will either
+be L<JSON::PP> or L<JSON>. If C<PERL_JSON_BACKEND> is set,
+this will return L<JSON> as further delegation is handled by
+the L<JSON> module. See L</ENVIRONMENT> for details.
+
+=head2 json_decoder
+
+ my $decoder = Parse::CPAN::Meta->json_decoder;
+
+Returns the module name of the JSON decoder. Unlike L</json_backend>, this
+is not necessarily a full L<JSON>-style module, but only something that will
+provide a C<decode_json> subroutine. If C<CPAN_META_JSON_DECODER> is set,
+this will be whatever that's set to. If not, this will be whatever has
+been selected as L</json_backend>. See L</ENVIRONMENT> for more notes.
+
+=head1 FUNCTIONS
+
+For maintenance clarity, no functions are exported by default. These functions
+are available for backwards compatibility only and are best avoided in favor of
+C<load_file>.
+
+=head2 Load
+
+ my @yaml = Parse::CPAN::Meta::Load( $string );
+
+Parses a string containing a valid YAML stream into a list of Perl data
+structures.
+
+=head2 LoadFile
+
+ my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );
+
+Reads the YAML stream from a file instead of a string.
+
+=head1 ENVIRONMENT
+
+=head2 CPAN_META_JSON_DECODER
+
+By default, L<JSON::PP> will be used for deserializing JSON data. If the
+C<CPAN_META_JSON_DECODER> environment variable exists, this is expected to
+be the name of a loadable module that provides a C<decode_json> subroutine,
+which will then be used for deserialization. Relying only on the existence
+of said subroutine allows for maximum compatibility, since this API is
+provided by all of L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS>,
+L<JSON::MaybeXS>, L<JSON::Tiny>, and L<Mojo::JSON>.
+
+=head2 CPAN_META_JSON_BACKEND
+
+By default, L<JSON::PP> will be used for deserializing JSON data. If the
+C<CPAN_META_JSON_BACKEND> environment variable exists, this is expected to
+be the name of a loadable module that provides the L<JSON> API, since
+downstream code expects to be able to call C<new> on this class. As such,
+while L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS> and L<JSON::MaybeXS> will
+work for this, to use L<Mojo::JSON> or L<JSON::Tiny> for decoding requires
+setting L</CPAN_META_JSON_DECODER>.
+
+=head2 PERL_JSON_BACKEND
+
+If the C<CPAN_META_JSON_BACKEND> environment variable does not exist, and if
+C<PERL_JSON_BACKEND> environment variable exists, is true and is not
+"JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
+used to interpret C<PERL_JSON_BACKEND>. If L<JSON> is not installed or is too
+old, an exception will be thrown. Note that at the time of writing, the only
+useful values are 1, which will tell L<JSON> to guess, or L<JSON::XS> - if
+you want to use a newer JSON module, see L</CPAN_META_JSON_BACKEND>.
+
+=head2 PERL_YAML_BACKEND
+
+By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
+the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
+as a module to use for deserialization. The given module must be installed,
+must load correctly and must implement the C<Load()> function or an exception
+will be thrown.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+There are three test data directories:
+
+- 'data-test': These files are valid META files that test *specific*
+ conversions and are expected to have specific data in them during
+ testing. Do not put new test data here unless you are sure it meets all
+ requirements needed to pass.
+
+- 'data-valid': These files are valid META files. Some may be improved by
+ the Converter (particularly upconverting from ancient specs).
+
+- 'data-fixable': These files are bad META files that fail validation, but
+ can be fixed via the Converter.
+
+- 'data-fail': These files are bad META files that fail validation and
+ can't be fixed.
use CPAN::Meta::Converter;
use File::Spec;
use IO::Dir;
-use Parse::CPAN::Meta 1.4400;
+use Parse::CPAN::Meta;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my @data_dirs = qw( t/data-valid t/data-fixable );
my @files = sort map {
use CPAN::Meta::Converter;
use File::Spec;
use IO::Dir;
-use Parse::CPAN::Meta 1.4400;
+use Parse::CPAN::Meta;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my $data_dir = IO::Dir->new( 't/data-fail' );
my @files = sort grep { /^\w/ } $data_dir->read;
use CPAN::Meta::Converter;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my $spec2 = {
version => '2',
use File::Spec;
use File::Basename qw/basename/;
use IO::Dir;
-use Parse::CPAN::Meta 1.4400;
+use Parse::CPAN::Meta;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
# mock file object
package
--- /dev/null
+{
+ "abstract" : "Author tests making sure correct line endings are used",
+ "author" : [
+ "Florian Ragwitz <rafl@debian.org>",
+ "Caleb Cushing <xenoterracide@gmail.com>",
+ "Karen Etheridge <ether@cpan.org>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Dist::Zilla version 5.035, CPAN::Meta::Converter version 2.150002",
+ "keywords" : [
+ "plugin",
+ "test",
+ "testing",
+ "author",
+ "development",
+ "whitespace",
+ "newline",
+ "linefeed",
+ "formatting"
+ ],
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : 2
+ },
+ "name" : "Dist-Zilla-Plugin-Test-EOL",
+ "no_index" : {
+ "directory" : [
+ "t",
+ "xt"
+ ]
+ },
+ "prereqs" : {
+ "configure" : {
+ "requires" : {
+ "Module::Build::Tiny" : "0.039",
+ "perl" : "5.006"
+ }
+ },
+ "develop" : {
+ "recommends" : {
+ "Dist::Zilla::PluginBundle::Author::ETHER" : "0.092"
+ },
+ "requires" : {
+ "Dist::Zilla" : "5"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Data::Section" : "0.004",
+ "Dist::Zilla::File::InMemory" : "0",
+ "Dist::Zilla::Role::FileFinderUser" : "0",
+ "Dist::Zilla::Role::FileGatherer" : "0",
+ "Dist::Zilla::Role::FileMunger" : "0",
+ "Dist::Zilla::Role::PrereqSource" : "0",
+ "Dist::Zilla::Role::TextTemplate" : "0",
+ "Moose" : "0",
+ "Moose::Util::TypeConstraints" : "0",
+ "Path::Tiny" : "0",
+ "Sub::Exporter::ForMethods" : "0",
+ "namespace::autoclean" : "0",
+ "perl" : "5.006",
+ "strict" : "0",
+ "warnings" : "0"
+ }
+ },
+ "build" : {
+ "requires" : {
+ "Build::Requires": "1.1",
+ "Test::More" : "0"
+ }
+ },
+ "test" : {
+ "recommends" : {
+ "CPAN::Meta" : "2.120900"
+ },
+ "requires" : {
+ "Test::More" : "0.88",
+ "Test::Requires" : "1.2"
+ }
+ }
+ },
+ "provides" : {
+ "Dist::Zilla::Plugin::EOLTests" : {
+ "file" : "lib/Dist/Zilla/Plugin/EOLTests.pm",
+ "version" : "0.18",
+ "x_deprecated" : 1
+ },
+ "Dist::Zilla::Plugin::Test::EOL" : {
+ "file" : "lib/Dist/Zilla/Plugin/Test/EOL.pm",
+ "version" : "0.18"
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "mailto" : "bug-Dist-Zilla-Plugin-Test-EOL@rt.cpan.org",
+ "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Dist-Zilla-Plugin-Test-EOL"
+ },
+ "homepage" : "https://github.com/karenetheridge/Dist-Zilla-Plugin-Test-EOL",
+ "repository" : {
+ "type" : "git",
+ "url" : "https://github.com/karenetheridge/Dist-Zilla-Plugin-Test-EOL.git",
+ "web" : "https://github.com/karenetheridge/Dist-Zilla-Plugin-Test-EOL"
+ },
+ "x_IRC" : "irc://irc.perl.org/#distzilla",
+ "x_MailingList" : "http://dzil.org/#mailing-list"
+ },
+ "version" : "0.18",
+ "x_Dist_Zilla" : {
+ "perl" : {
+ "version" : "5.021010"
+ },
+ "plugins" : [
+ {
+ "class" : "Dist::Zilla::Plugin::Bootstrap::lib",
+ "config" : {
+ "Dist::Zilla::Role::Bootstrap" : {
+ "try_built" : null
+ }
+ },
+ "name" : "Bootstrap::lib",
+ "version" : "1.001000"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::VerifyPhases",
+ "name" : "@Author::ETHER/PHASE VERIFICATION",
+ "version" : "0.010"
+ }
+ ],
+ "zilla" : {
+ "class" : "Dist::Zilla::Dist::Builder",
+ "config" : {
+ "is_trial" : ""
+ },
+ "version" : "5.035"
+ }
+ },
+ "x_authority" : "cpan:FLORA",
+ "x_authority_from_module" : "Dist::Zilla::Plugin::Test::EOL",
+ "x_contributors" : [
+ "Olivier Mengue <dolmen@cpan.org>",
+ "Shlomi Fish <shlomif@shlomifish.org>"
+ ],
+ "x_permissions_from_module" : "Dist::Zilla::Plugin::Test::EOL"
+}
--- /dev/null
+---
+X_deep:
+ deep: structure
+abstract: 'Build and install Perl modules'
+author:
+ - 'Ken Williams <kwilliams@cpan.org>'
+ - 'Module-Build List <module-build@perl.org>'
+build_requires:
+ Test::More: '0'
+dynamic_config: 1
+generated_by: 'Module::Build version 0.36, CPAN::Meta::Converter version $VERSION'
+keywords:
+ - toolchain
+ - cpan
+ - dual-life
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: '1.4'
+name: Module-Build
+optional_features:
+ domination:
+ description: 'Take over the world'
+ requires:
+ Machine::Weather: '2.0'
+recommends:
+ Archive::Tar: '1.00'
+ ExtUtils::Install: '0.3'
+ ExtUtils::ParseXS: '2.02'
+ Pod::Text: '0'
+ YAML: '0.35'
+requires:
+ Config: '0'
+ Cwd: '0'
+ Data::Dumper: '0'
+ ExtUtils::Install: '0'
+ File::Basename: '0'
+ File::Compare: '0'
+ File::Copy: '0'
+ File::Find: '0'
+ File::Path: '0'
+ File::Spec: '0'
+ IO::File: '0'
+ perl: '5.006'
+resources:
+ license: http://dev.perl.org/licenses/
+version: '0.36'
+x_authority: cpan:FLORA
+x_serialization_backend: 'CPAN::Meta::YAML version 0.015'
--- /dev/null
+{
+ "X_deep" : {
+ "deep" : "structure"
+ },
+ "abstract" : "Build and install Perl modules",
+ "author" : [
+ "Ken Williams <kwilliams@cpan.org>",
+ "Module-Build List <module-build@perl.org>"
+ ],
+ "description" : "Module::Build is a system for building, testing, and installing Perl modules. It is meant to be an alternative to ExtUtils::MakeMaker... blah blah blah",
+ "dynamic_config" : 1,
+ "generated_by" : "Module::Build version 0.36",
+ "keywords" : [
+ "toolchain",
+ "cpan",
+ "dual-life"
+ ],
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Module-Build",
+ "optional_features" : {
+ "domination" : {
+ "description" : "Take over the world",
+ "prereqs" : {
+ "develop" : {
+ "requires" : {
+ "Genius::Evil" : "1.234"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Machine::Weather" : "2.0"
+ }
+ }
+ }
+ }
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "Test::More" : "0"
+ }
+ },
+ "runtime" : {
+ "recommends" : {
+ "Archive::Tar" : "1.00",
+ "ExtUtils::Install" : "0.3",
+ "ExtUtils::ParseXS" : "2.02",
+ "Pod::Text" : "0",
+ "YAML" : "0.35"
+ },
+ "requires" : {
+ "Config" : "0",
+ "Cwd" : "0",
+ "Data::Dumper" : "0",
+ "ExtUtils::Install" : "0",
+ "File::Basename" : "0",
+ "File::Compare" : "0",
+ "File::Copy" : "0",
+ "File::Find" : "0",
+ "File::Path" : "0",
+ "File::Spec" : "0",
+ "IO::File" : "0",
+ "perl" : "5.006"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "license" : [
+ "http://dev.perl.org/licenses/"
+ ]
+ },
+ "version" : "0.36",
+ "x_authority" : "cpan:FLORA",
+ "x_serialization_backend" : "JSON::PP version 2.27300"
+}
--- /dev/null
+---
+abstract: 'Author tests making sure correct line endings are used'
+author:
+ - 'Florian Ragwitz <rafl@debian.org>'
+ - 'Caleb Cushing <xenoterracide@gmail.com>'
+ - 'Karen Etheridge <ether@cpan.org>'
+build_requires:
+ Build::Requires: '1.1'
+ Test::More: '0.88'
+ Test::Requires: '1.2'
+configure_requires:
+ Module::Build::Tiny: '0.039'
+ perl: '5.006'
+dynamic_config: 0
+generated_by: 'Dist::Zilla version 5.035, CPAN::Meta::Converter version 2.150002'
+keywords:
+ - plugin
+ - test
+ - testing
+ - author
+ - development
+ - whitespace
+ - newline
+ - linefeed
+ - formatting
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: '1.4'
+name: Dist-Zilla-Plugin-Test-EOL
+no_index:
+ directory:
+ - t
+ - xt
+provides:
+ Dist::Zilla::Plugin::EOLTests:
+ file: lib/Dist/Zilla/Plugin/EOLTests.pm
+ version: '0.18'
+ x_deprecated: 1
+ Dist::Zilla::Plugin::Test::EOL:
+ file: lib/Dist/Zilla/Plugin/Test/EOL.pm
+ version: '0.18'
+requires:
+ Data::Section: '0.004'
+ Dist::Zilla::File::InMemory: '0'
+ Dist::Zilla::Role::FileFinderUser: '0'
+ Dist::Zilla::Role::FileGatherer: '0'
+ Dist::Zilla::Role::FileMunger: '0'
+ Dist::Zilla::Role::PrereqSource: '0'
+ Dist::Zilla::Role::TextTemplate: '0'
+ Moose: '0'
+ Moose::Util::TypeConstraints: '0'
+ Path::Tiny: '0'
+ Sub::Exporter::ForMethods: '0'
+ namespace::autoclean: '0'
+ perl: '5.006'
+ strict: '0'
+ warnings: '0'
+resources:
+ IRC: irc://irc.perl.org/#distzilla
+ MailingList: http://dzil.org/#mailing-list
+ bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Dist-Zilla-Plugin-Test-EOL
+ homepage: https://github.com/karenetheridge/Dist-Zilla-Plugin-Test-EOL
+ repository: https://github.com/karenetheridge/Dist-Zilla-Plugin-Test-EOL.git
+version: '0.18'
+x_Dist_Zilla:
+ perl:
+ version: '5.021010'
+ plugins:
+ -
+ class: Dist::Zilla::Plugin::Bootstrap::lib
+ config:
+ Dist::Zilla::Role::Bootstrap:
+ try_built: ~
+ name: Bootstrap::lib
+ version: '1.001000'
+ -
+ class: Dist::Zilla::Plugin::VerifyPhases
+ name: '@Author::ETHER/PHASE VERIFICATION'
+ version: '0.010'
+ zilla:
+ class: Dist::Zilla::Dist::Builder
+ config:
+ is_trial: ''
+ version: '5.035'
+x_authority: cpan:FLORA
+x_authority_from_module: Dist::Zilla::Plugin::Test::EOL
+x_contributors:
+ - 'Olivier Mengue <dolmen@cpan.org>'
+ - 'Shlomi Fish <shlomif@shlomifish.org>'
+x_permissions_from_module: Dist::Zilla::Plugin::Test::EOL
--- /dev/null
+package Parse::CPAN::Meta::Test;
+
+use strict;
+use Test::More ();
+use Parse::CPAN::Meta;
+use File::Spec;
+
+use vars qw{@ISA @EXPORT};
+BEGIN {
+ require Exporter;
+ @ISA = qw{ Exporter };
+ @EXPORT = qw{
+ tests yaml_ok yaml_error slurp load_ok
+ test_data_directory
+ };
+}
+
+sub test_data_directory {
+ return( "corpus" );
+}
+
+# 22 tests per call to yaml_ok
+# 4 tests per call to load_ok
+sub tests {
+ return ( tests => count(@_) );
+}
+
+sub count {
+ my $yaml_ok = shift || 0;
+ my $load_ok = shift || 0;
+ my $single = shift || 0;
+ my $count = $yaml_ok * 3 + $load_ok * 4 + $single;
+ return $count;
+}
+
+sub yaml_ok {
+ my $string = shift;
+ my $array = shift;
+ my $name = shift || 'unnamed';
+
+ # Does the string parse to the structure
+ my $yaml_copy = $string;
+ my @yaml = eval { Parse::CPAN::Meta::Load( $yaml_copy ); };
+ Test::More::is( $@, '', "$name: Parse::CPAN::Meta parses without error" );
+ Test::More::is( $yaml_copy, $string, "$name: Parse::CPAN::Meta does not modify the input string" );
+ SKIP: {
+ Test::More::skip( "Shortcutting after failure", 1 ) if $@;
+ Test::More::is_deeply( \@yaml, $array, "$name: Parse::CPAN::Meta parses correctly" );
+ }
+
+ # Return true as a convenience
+ return 1;
+}
+
+sub yaml_error {
+ my $string = shift;
+ my $yaml = eval { Parse::CPAN::Meta::Load( $string ); };
+ Test::More::like( $@, qr/$_[0]/, "CPAN::Meta::YAML throws expected error" );
+}
+
+sub slurp {
+ my $file = shift;
+ my $layer = shift;
+ $layer = "" unless defined $layer;
+ local $/ = undef;
+ open my $fh, "<$layer", $file or die "open($file) failed: $!";
+ my $source = <$fh>;
+ close( $fh ) or die "close($file) failed: $!";
+ $source;
+}
+
+sub load_ok {
+ my $name = shift;
+ my $file = shift;
+ my $size = shift;
+ my $layer = shift;
+ Test::More::ok( -f $file, "Found $name" ) or Test::More::diag("Searched at '$file'");
+ Test::More::ok( -r $file, "Can read $name" );
+ my $content = slurp( $file, $layer );
+ Test::More::ok( (defined $content and ! ref $content), "Loaded $name" );
+ Test::More::ok( ($size < length $content), "Content of $name larger than $size bytes" );
+ return $content;
+}
+
+1;
sub _slurp { do { local(@ARGV,$/)=shift(@_); <> } }
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my $data_dir = IO::Dir->new( 't/data-fixable' );
my @files = sort grep { /^\w/ } $data_dir->read;
use CPAN::Meta;
use CPAN::Meta::Merge;
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
+
my %base = (
abstract => 'This is a test',
author => ['A.U. Thor'],
is(
eval { $merger->merge(\%base, { abstract => 'And now for something else' }) },
undef,
- 'Trying to merge different author gives an exception',
+ 'Trying to merge different abstract gives an exception',
);
like $@, qr/^Can't merge attribute abstract/, 'Exception looks right';
'Trying to merge a new key for provides.$module is permitted; identical values are preserved',
);
+my $extra_merger = CPAN::Meta::Merge->new(
+ default_version => '2',
+ extra_mappings => {
+ 'x_toolkit' => 'set_addition',
+ 'x_meta_meta' => {
+ name => 'identical',
+ tags => 'set_addition',
+ }
+ }
+);
+
+my $extra_results = $extra_merger->merge(\%base, {
+ x_toolkit => [ 'marble' ],
+ x_meta_meta => {
+ name => 'Test',
+ tags => [ 'Testing' ],
+ }
+ },
+ { x_toolkit => [ 'trike'],
+ x_meta_meta => {
+ name => 'Test',
+ tags => [ 'TDD' ],
+ }
+ }
+);
+
+my $expected_nested_extra = {
+ name => 'Test',
+ tags => [ 'Testing', 'TDD' ],
+};
+is_deeply($extra_results->{x_toolkit}, [ 'marble', 'trike' ], 'Extra mapping fields are merged');
+is_deeply($extra_results->{x_meta_meta}, $expected_nested_extra, 'Nested extra mapping fields are merged' );
+
+my $adds_to = sub {
+ my ($left, $right, $path) = @_;
+ if ($right !~ /^\Q$left\E/) {
+ die sprintf "Can't merge attribute %s: '%s' does not start with '%s'", join('.', @{$path}), $right, $left;
+ }
+ return $right;
+};
+
+$extra_merger = CPAN::Meta::Merge->new(default_version => '2', extra_mappings => { 'abstract' => \&$adds_to } );
+my $extra_results2 = $extra_merger->merge({ abstract => 'This is a test.'}, { abstract => 'This is a test. Includes more detail..' } );
+is($extra_results2->{abstract}, 'This is a test. Includes more detail..', 'Extra mapping fields overwrite existing mappings');
+my $extra_failure = eval { $extra_merger->merge({ abstract => 'This is a test.'}, { abstract => 'This is a better test.' } ) };
+is($extra_failure, undef, 'Extra mapping produces a failure');
+like $@, qr/does not start with/, 'Exception looks right';
+
+
# issue 67
@base{qw/name version release_status/} = qw/Foo-Bar 0.01 testing/;
use Test::More 0.88;
use CPAN::Meta;
-
+use Storable qw(dclone);
use Scalar::Util qw(blessed);
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my $distmeta = {
name => 'Module-Build',
X_deep => { deep => 'structure' },
};
-my $meta = CPAN::Meta->new($distmeta);
+my $meta = CPAN::Meta->new(dclone $distmeta);
is(
blessed($meta->as_struct),
$chk_feature->( $meta->feature('domination') );
+
+sub read_file {
+ my $filename = shift;
+ open my $fh, '<', $filename;
+ local $/;
+ my $string = <$fh>;
+ $string =~ s/\$VERSION/$CPAN::Meta::VERSION/g;
+ $string;
+}
+
+sub clean_backends {
+ my $string = shift;
+ $string =~ s{"?generated_by.*}{};
+ $string =~ s{"?x_serialization_backend.*}{};
+ return $string;
+}
+
+is(
+ clean_backends($meta->as_string()),
+ clean_backends(read_file('t/data-valid/META-2.json')),
+ 'as_string with no arguments defaults to version 2 and JSON',
+);
+
+is(
+ clean_backends($meta->as_string({ version => 2 })),
+ clean_backends(read_file('t/data-valid/META-2.json')),
+ 'as_string using version 2 defaults to JSON',
+);
+
+is(
+ clean_backends($meta->as_string({ version => 1.4 })),
+ clean_backends(read_file('t/data-valid/META-1_4.yml')),
+ 'as_string using version 1.4 defaults to YAML',
+);
+
done_testing;
# vim: ts=2 sts=2 sw=2 et :
use CPAN::Meta;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my %distmeta = (
name => 'Module-Billed',
use CPAN::Meta;
use CPAN::Meta::Merge;
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
+
my %base = (
abstract => 'This is a test',
author => ['A.U. Thor'],
--- /dev/null
+#!/usr/bin/perl
+
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
+
+# Testing of a known-bad file from an editor
+
+use strict;
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use lib 't/lib';
+use File::Spec::Functions ':ALL';
+use Parse::CPAN::Meta;
+use Parse::CPAN::Meta::Test;
+# use Test::More skip_all => 'Temporarily ignoring failing test';
+use Test::More 'no_plan';
+use utf8;
+
+#####################################################################
+# Testing that Perl::Smith config files work
+
+my $want = {
+ "abstract" => "a set of version requirements for a CPAN dist",
+ "author" => [ 'Ricardo Signes <rjbs@cpan.org>' ],
+ "build_requires" => {
+ "Test::More" => "0.88"
+ },
+ "configure_requires" => {
+ "ExtUtils::MakeMaker" => "6.31"
+ },
+ "generated_by" => "Dist::Zilla version 2.100991",
+ "license" => "perl",
+ "meta-spec" => {
+ "url" => "http://module-build.sourceforge.net/META-spec-v1.4.html",
+ "version" => 1.4
+ },
+ "name" => "Version-Requirements",
+ "recommends" => {},
+ "requires" => {
+ "Carp" => "0",
+ "Scalar::Util" => "0",
+ "version" => "0.77"
+ },
+ "resources" => {
+ "repository" => "git://git.codesimply.com/Version-Requirements.git"
+ },
+ "version" => "0.101010",
+ "x_contributors" => [
+ "Dagfinn Ilmari Mannsåker <ilmari\@ilmari.org>",
+ ],
+};
+
+my $meta_json = catfile( test_data_directory(), 'META-VR.json' );
+my $meta_yaml = catfile( test_data_directory(), 'META-VR.yml' );
+my $bare_yaml_meta = catfile( test_data_directory(), 'bareyaml.meta' );
+my $bad_yaml_meta = catfile( test_data_directory(), 'BadMETA.yml' );
+my $CL018_yaml_meta = catfile( test_data_directory(), 'CL018_yaml.meta' );
+
+# These test YAML/JSON detection without the typical file name suffix
+my $yaml_meta = catfile( test_data_directory(), 'yaml.meta' );
+my $json_meta = catfile( test_data_directory(), 'json.meta' );
+
+### YAML tests
+{
+ local $ENV{PERL_YAML_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get CPAN::META::YAML
+
+ is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
+ my $from_yaml = Parse::CPAN::Meta->load_file( $meta_yaml );
+ is_deeply($from_yaml, $want, "load from YAML file results in expected data");
+}
+
+{
+ local $ENV{PERL_YAML_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get CPAN::META::YAML
+
+ note '';
+ is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
+ my $from_yaml = Parse::CPAN::Meta->load_file( $yaml_meta );
+ is_deeply($from_yaml, $want, "load from YAML .meta file results in expected data");
+}
+
+{
+ local $ENV{PERL_YAML_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get CPAN::META::YAML
+
+ note '';
+ is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
+ my $from_yaml = Parse::CPAN::Meta->load_file( $bare_yaml_meta );
+ is_deeply($from_yaml, $want, "load from bare YAML .meta file results in expected data");
+}
+
+{
+ local $ENV{PERL_YAML_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get CPAN::META::YAML
+
+ note '';
+ is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
+ my $from_yaml = Parse::CPAN::Meta->load_file( $CL018_yaml_meta );
+ like($from_yaml->{x_contributors}[5], qr/Olivier Mengu/, "Open question: what to expect from double encoded UTF-8");
+}
+
+{
+ local $ENV{PERL_YAML_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get CPAN::META::YAML
+
+ note '';
+ is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
+ my $yaml = load_ok( $meta_yaml, $meta_yaml, 100, ":encoding(UTF-8)");
+ my $from_yaml = Parse::CPAN::Meta->load_yaml_string( $yaml );
+ is_deeply($from_yaml, $want, "load from YAML str results in expected data");
+}
+
+{
+ local $ENV{PERL_YAML_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get CPAN::META::YAML
+
+ note '';
+ is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
+ my @yaml = Parse::CPAN::Meta::LoadFile( $bad_yaml_meta );
+ is($yaml[0]{author}[0], 'Olivier Mengu\xE9', "Bad UTF-8 is replaced");
+}
+
+
+SKIP: {
+ note '';
+ skip 'these tests are for cpan builds only', 2 if $ENV{PERL_CORE};
+ skip "YAML module not installed", 2
+ unless eval "require YAML; 1";
+ local $ENV{PERL_YAML_BACKEND} = 'YAML';
+
+ is(Parse::CPAN::Meta->yaml_backend(), 'YAML', 'yaml_backend(): YAML');
+ my $yaml = load_ok( $meta_yaml, $meta_yaml, 100, ":encoding(UTF-8)");
+ my $from_yaml = Parse::CPAN::Meta->load_yaml_string( $yaml );
+ is_deeply($from_yaml, $want, "load_yaml_string using PERL_YAML_BACKEND");
+}
+
+### JSON tests
+{
+ # JSON tests with JSON::PP
+ local $ENV{PERL_JSON_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get JSON::PP
+
+ note '';
+ is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
+ my $from_json = Parse::CPAN::Meta->load_file( $meta_json );
+ is_deeply($from_json, $want, "load from JSON file results in expected data");
+}
+
+{
+ # JSON tests with JSON::PP
+ local $ENV{PERL_JSON_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get JSON::PP
+
+ note '';
+ is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
+ my $from_json = Parse::CPAN::Meta->load_file( $json_meta );
+ is_deeply($from_json, $want, "load from JSON .meta file results in expected data");
+}
+
+{
+ # JSON tests with JSON::PP
+ local $ENV{PERL_JSON_BACKEND} if not $ENV{PERL_CORE}; # ensure we always get JSON::PP
+
+ note '';
+ is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
+ my $json = load_ok( $meta_json, $meta_json, 100, "encoding(UTF-8)");
+ my $from_json = Parse::CPAN::Meta->load_json_string( $json );
+ is_deeply($from_json, $want, "load from JSON str results in expected data");
+}
+
+{
+ # JSON tests with JSON::PP, take 2
+ local $ENV{PERL_JSON_BACKEND} = 0 if not $ENV{PERL_CORE}; # request JSON::PP
+
+ note '';
+ is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
+ my $json = load_ok( $meta_json, $meta_json, 100, ":encoding(UTF-8)");
+ my $from_json = Parse::CPAN::Meta->load_json_string( $json );
+ is_deeply($from_json, $want, "load_json_string with PERL_JSON_BACKEND = 0");
+}
+
+{
+ # JSON tests with JSON::PP, take 3
+ local $ENV{PERL_JSON_BACKEND} = 'JSON::PP' if not $ENV{PERL_CORE}; # request JSON::PP
+
+ note '';
+ is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
+ my $json = load_ok( $meta_json, $meta_json, 100, ":encoding(UTF-8)");
+ my $from_json = Parse::CPAN::Meta->load_json_string( $json );
+ is_deeply($from_json, $want, "load_json_string with PERL_JSON_BACKEND = 'JSON::PP'");
+}
+
+SKIP: {
+ # JSON tests with fake backend
+
+ note '';
+ skip 'these tests are for cpan builds only', 2 if $ENV{PERL_CORE};
+
+ { package MyJSONThingy; $INC{'MyJSONThingy.pm'} = __FILE__; require JSON::PP;
+ sub decode_json { JSON::PP::decode_json(@_) } }
+
+ local $ENV{CPAN_META_JSON_DECODER} = 'MyJSONThingy'; # request fake backend
+
+ is(Parse::CPAN::Meta->json_decoder(), 'MyJSONThingy', 'json_decoder(): MyJSONThingy');
+ my $json = load_ok( $meta_json, $meta_json, 100, ":encoding(UTF-8)");
+ my $from_json = Parse::CPAN::Meta->load_json_string( $json );
+ is_deeply($from_json, $want, "load_json_string with PERL_JSON_DECODER = 'MyJSONThingy'");
+}
+
+SKIP: {
+ note '';
+ skip 'these tests are for cpan builds only', 2 if $ENV{PERL_CORE};
+ skip "JSON module version 2.5 not installed", 2
+ unless eval "require JSON; JSON->VERSION(2.5); 1";
+ local $ENV{PERL_JSON_BACKEND} = 1;
+
+ is(Parse::CPAN::Meta->json_backend(), 'JSON', 'json_backend(): JSON');
+ my $json = load_ok( $meta_json, $meta_json, 100, ":encoding(UTF-8)");
+ my $from_json = Parse::CPAN::Meta->load_json_string( $json );
+ is_deeply($from_json, $want, "load_json_string with PERL_JSON_BACKEND = 1");
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+
+# Testing of basic document structures
+
+use strict;
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 2;
+use Parse::CPAN::Meta ();
+
+my $one = <<'END_YAML';
+---
+- foo
+END_YAML
+
+my $two = <<'END_YAML';
+---
+- foo
+---
+- bar
+END_YAML
+
+my $one_scalar_tiny = Parse::CPAN::Meta::Load( $one );
+my $two_scalar_tiny = Parse::CPAN::Meta::Load( $two );
+
+is_deeply( $one_scalar_tiny, [ 'foo' ], 'one: Parsed correctly' );
+is_deeply( $two_scalar_tiny, [ 'bar' ], 'two: Parsed correctly' );
--- /dev/null
+#!/usr/bin/perl
+
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+
+# Testing of basic document structures
+
+use strict;
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 4;
+use Parse::CPAN::Meta;
+
+
+
+ok not(defined &main::Load), 'Load is not exported';
+ok not(defined &main::Dump), 'Dump is not exported';
+ok not(defined &main::LoadFile), 'LoadFile is not exported';
+ok not(defined &main::DumpFile), 'DumpFile is not exported';
--- /dev/null
+#!/usr/bin/perl
+
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+
+# Testing of basic document structures
+
+use strict;
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+use Test::More tests => 1;
+use Parse::CPAN::Meta ();
+
+my $one = <<'END_YAML';
+---
+- foo: - bar
+END_YAML
+
+my $one_scalar_tiny = eval { Parse::CPAN::Meta->load_yaml_string( $one ) };
+like( $@, '/illegal characters/', "error causes exception");
+
use CPAN::Meta::Prereqs;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
sub dies_ok (&@) {
my ($code, $qr, $comment) = @_;
use CPAN::Meta::Prereqs;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my $prereq_struct_1 = {
runtime => {
requires => {
'Test' => 0,
},
- }
+ x_type => {
+ 'Config' => 1,
+ },
+ },
+ x_phase => {
+ x_type => {
+ 'POSIX' => '1.23',
+ },
+ },
};
my $prereq_1 = CPAN::Meta::Prereqs->new($prereq_struct_1);
suggests => {
'Module::Build::Bob' => '20100101',
},
- }
+ },
+ x_phase => {
+ requires => {
+ 'JSON::PP' => '2.34',
+ },
+ },
};
my $prereq_2 = CPAN::Meta::Prereqs->new($prereq_struct_2);
suggests => {
'Module::Build::Bob' => '20100101',
},
+ x_type => {
+ 'Config' => 1,
+ },
+ },
+ x_phase => {
+ requires => {
+ 'JSON::PP' => '2.34',
+ },
+ x_type => {
+ 'POSIX' => '1.23',
+ },
},
};
use CPAN::Meta::Prereqs;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my $prereq_struct = {
runtime => {
requires => {
'Test' => 0,
},
- }
+ x_type => {
+ 'Config' => 1,
+ },
+ },
+ x_phase => {
+ requires => {
+ 'JSON::PP' => '2.34',
+ },
+ x_type => {
+ 'POSIX' => '1.23',
+ },
+ },
};
my $prereq = CPAN::Meta::Prereqs->new($prereq_struct);
use CPAN::Meta;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
# 1.4 repository upgrade
{
use CPAN::Meta;
use File::Temp 0.20 ();
-use Parse::CPAN::Meta 1.4400;
+use Parse::CPAN::Meta;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
my $distmeta = {
name => 'Module-Build',
use CPAN::Meta::Validator;
use File::Spec;
use IO::Dir;
-use Parse::CPAN::Meta 1.4400;
+use Parse::CPAN::Meta;
-delete $ENV{$_} for qw/PERL_JSON_BACKEND PERL_YAML_BACKEND/; # use defaults
+delete $ENV{PERL_YAML_BACKEND};
+delete $ENV{PERL_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_BACKEND};
+delete $ENV{CPAN_META_JSON_DECODER};
{
my @data_dirs = qw( t/data-test t/data-valid );
use if $] < 5.008 => 'IO::Scalar';
-$VERSION = '1.64';
+$VERSION = '1.64_01';
=head1 NAME
sub DESTROY { 1 }
}
+# load a module without searching the default entry for the current
+# directory
+sub _safe_load_module {
+ my $name = shift;
+
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+
+ eval "require $name; 1";
+}
+
sub _init_logger
{
- my $log4perl_loaded = eval "require Log::Log4perl; 1";
+ my $log4perl_loaded = _safe_load_module("Log::Log4perl");
unless( $log4perl_loaded )
{
{
$logger->debug( "Loading local::lib" );
- my $rc = eval { require local::lib; 1; };
+ my $rc = _safe_load_module("local::lib");
unless( $rc ) {
$logger->die( "Could not load local::lib" );
}
{
my $path = shift;
- my $loaded = eval "require LWP::Simple; 1;";
+ my $loaded = _safe_load_module("LWP::Simple");
croak "You need LWP::Simple to use features that fetch files from CPAN\n"
unless $loaded;
{
my $args = shift;
- my $loaded = eval "require Archive::Extract; 1;";
+ my $loaded = _safe_load_module("Archive::Extract");
croak "You need Archive::Extract to use features that gitify distributions\n"
unless $loaded;
sub _get_changes_file
{
croak "Reading Changes files requires LWP::Simple and URI\n"
- unless eval "require LWP::Simple; require URI; 1";
+ unless _safe_load_module("LWP::Simple") && _safe_load_module("URI");
my $url = shift;
# vim: ts=4 sts=4 sw=4:
use strict;
package CPAN;
-$CPAN::VERSION = '2.14';
+$CPAN::VERSION = '2.14_01';
$CPAN::VERSION =~ s/_//;
# we need to run chdir all over and we would get at wrong libraries
]
};
if ($usable->{$mod}) {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
for my $c (0..$#{$usable->{$mod}}) {
my $code = $usable->{$mod}[$c];
my $ret = eval { &$code() };
$CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
return 0;
}
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
my $file = $mod;
my $obj;
$file =~ s|::|/|g;
#!/usr/local/bin/perl
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use vars qw($VERSION);
use Config;
use Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
-$VERSION = "0.26";
+$VERSION = "0.27";
@ISA = ("Exporter");
@EXPORT_OK = qw( plv2hash summary myconfig signature );
%EXPORT_TAGS = (
PERL_MEM_LOG_STDERR
PERL_MEM_LOG_TIMESTAMP
PERL_NEW_COPY_ON_WRITE
+ PERL_OP_PARENT
PERL_PERTURB_KEYS_DETERMINISTIC
PERL_PERTURB_KEYS_DISABLED
PERL_PERTURB_KEYS_RANDOM
BEGIN {
use Test::More;
- my $tests = 96;
+ my $tests = 97;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 96;
+ my $tests = 97;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 95;
+ my $tests = 96;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 97;
+ my $tests = 98;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 97;
+ my $tests = 98;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 96;
+ my $tests = 97;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 154;
+ my $tests = 155;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 115;
+ my $tests = 116;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 115;
+ my $tests = 116;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 115;
+ my $tests = 116;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 116;
+ my $tests = 117;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 116;
+ my $tests = 117;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 116;
+ my $tests = 117;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 116;
+ my $tests = 117;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 116;
+ my $tests = 117;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
use strict;
use warnings;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-use Fcntl;
+use vars qw($VERSION @ISA @EXPORT_OK);
+use Fcntl qw(O_RDONLY);
use integer;
-$VERSION = '5.95';
+$VERSION = '5.96';
require Exporter;
require DynaLoader;
=head1 COPYRIGHT AND LICENSE
-Copyright (C) 2003-2015 Mark Shelor
+Copyright (C) 2003-2016 Mark Shelor
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
## shasum: filter for computing SHA digests (ref. sha1sum/md5sum)
##
- ## Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved
+ ## Copyright (C) 2003-2016 Mark Shelor, All Rights Reserved
##
- ## Version: 5.95
- ## Sat Jan 10 12:15:36 MST 2015
+ ## Version: 5.96
+ ## Wed Jul 27 20:04:34 MST 2016
## shasum SYNOPSIS adapted from GNU Coreutils sha1sum. Add
## "-a" option for algorithm selection,
## "-0" option for reading bit strings, and
## "-p" option for portable digests (to be deprecated).
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
use strict;
use warnings;
use Fcntl;
=head1 AUTHOR
-Copyright (c) 2003-2015 Mark Shelor <mshelor@cpan.org>.
+Copyright (c) 2003-2016 Mark Shelor <mshelor@cpan.org>.
=head1 SEE ALSO
END_OF_POD
-my $VERSION = "5.95";
+my $VERSION = "5.96";
sub usage {
my($err, $msg) = @_;
*
* Ref: NIST FIPS PUB 180-4 Secure Hash Standard
*
- * Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved
+ * Copyright (C) 2003-2016 Mark Shelor, All Rights Reserved
*
- * Version: 5.95
- * Sat Jan 10 12:15:36 MST 2015
+ * Version: 5.96
+ * Wed Jul 27 20:04:34 MST 2016
*
*/
for (i = 0UL; i < bitcnt; i++) {
if (BITSET(bitstr, i))
- SETBIT(s->block, s->blockcnt), s->blockcnt++;
+ SETBIT(s->block, s->blockcnt);
else
- CLRBIT(s->block, s->blockcnt), s->blockcnt++;
- if (s->blockcnt == s->blocksize)
+ CLRBIT(s->block, s->blockcnt);
+ if (++s->blockcnt == s->blocksize)
s->sha(s, s->block), s->blockcnt = 0;
}
return(bitcnt);
*
* Ref: NIST FIPS PUB 180-4 Secure Hash Standard
*
- * Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved
+ * Copyright (C) 2003-2016 Mark Shelor, All Rights Reserved
*
- * Version: 5.95
- * Sat Jan 10 12:15:36 MST 2015
+ * Version: 5.96
+ * Wed Jul 27 20:04:34 MST 2016
*
*/
*
* Ref: NIST FIPS PUB 180-4 Secure Hash Standard
*
- * Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved
+ * Copyright (C) 2003-2016 Mark Shelor, All Rights Reserved
*
- * Version: 5.95
- * Sat Jan 10 12:15:36 MST 2015
+ * Version: 5.96
+ * Wed Jul 27 20:04:34 MST 2016
*
*/
*
* Ref: NIST FIPS PUB 180-4 Secure Hash Standard
*
- * Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved
+ * Copyright (C) 2003-2016 Mark Shelor, All Rights Reserved
*
- * Version: 5.95
- * Sat Jan 10 12:15:36 MST 2015
+ * Version: 5.96
+ * Wed Jul 27 20:04:34 MST 2016
*
* The following macros supply placeholder values that enable the
* sha.c module to successfully compile when 64-bit integer types
use strict;
use vars qw($VERSION %MMAP $AUTOLOAD);
-$VERSION = "1.17";
+$VERSION = "1.17_01";
%MMAP = (
"SHA-1" => [["Digest::SHA", 1], "Digest::SHA1", ["Digest::SHA2", 1]],
unless (exists ${"$class\::"}{"VERSION"}) {
my $pm_file = $class . ".pm";
$pm_file =~ s{::}{/}g;
- eval { require $pm_file };
+ eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require $pm_file
+ };
if ($@) {
$err ||= $@;
next;
#
-# $Id: Encode.pm,v 2.84 2016/04/11 07:16:52 dankogai Exp $
+# $Id: Encode.pm,v 2.86 2016/08/10 18:08:01 dankogai Exp $
#
package Encode;
use strict;
use warnings;
-our $VERSION = sprintf "%d.%02d", q$Revision: 2.84 $ =~ /(\d+)/g;
+our $VERSION = sprintf "%d.%02d", q$Revision: 2.86 $ =~ /(\d+)/g;
use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
use XSLoader ();
XSLoader::load( __PACKAGE__, $VERSION );
eval {
local $SIG{__DIE__};
local $SIG{__WARN__};
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
require Encode::ConfigLocal;
};
require Carp;
Carp::croak("Unknown encoding '$to'");
}
- my $uni = $f->decode($string);
- $_[0] = $string = $t->encode( $uni, $check );
+
+ # For Unicode, warnings need to be caught and re-issued at this level
+ # so that callers can disable utf8 warnings lexically.
+ my $uni;
+ if ( ref($f) eq 'Encode::Unicode' ) {
+ my $warn = '';
+ {
+ local $SIG{__WARN__} = sub { $warn = shift };
+ $uni = $f->decode($string);
+ }
+ warnings::warnif('utf8', $warn) if length $warn;
+ }
+ else {
+ $uni = $f->decode($string);
+ }
+
+ if ( ref($t) eq 'Encode::Unicode' ) {
+ my $warn = '';
+ {
+ local $SIG{__WARN__} = sub { $warn = shift };
+ $_[0] = $string = $t->encode( $uni, $check );
+ }
+ warnings::warnif('utf8', $warn) if length $warn;
+ }
+ else {
+ $_[0] = $string = $t->encode( $uni, $check );
+ }
+
return undef if ( $check && length($uni) );
return defined( $_[0] ) ? length($string) : undef;
}
canonical name or an alias. For encoding names and aliases, see
L</"Defining Aliases">. For CHECK, see L</"Handling Malformed Data">.
+B<CAVEAT>: the input scalar I<STRING> might be modified in-place depending
+on what is set in CHECK. See L</LEAVE_SRC> if you want your inputs to be
+left unchanged.
+
For example, to convert a string from Perl's internal format into
ISO-8859-1, also known as Latin1:
and aliases, see L</"Defining Aliases">; for I<CHECK>, see L</"Handling
Malformed Data">.
+B<CAVEAT>: the input scalar I<OCTETS> might be modified in-place depending
+on what is set in CHECK. See L</LEAVE_SRC> if you want your inputs to be
+left unchanged.
+
For example, to convert ISO-8859-1 data into a string in Perl's
internal format:
it is quite possible for this function to fail.
For CHECK, see L</"Handling Malformed Data">.
+B<CAVEAT>: the input I<$octets> might be modified in-place depending on
+what is set in CHECK. See L</LEAVE_SRC> if you want your inputs to be
+left unchanged.
+
=head2 Listing available encodings
use Encode;
/*
- $Id: Encode.xs,v 2.35 2016/01/22 06:33:07 dankogai Exp $
+ $Id: Encode.xs,v 2.37 2016/08/10 18:08:45 dankogai Exp dankogai $
*/
#define PERL_NO_GET_CONTEXT
STRLEN ulen;
SV *fallback_cb;
int check;
+ U8 *d;
+ STRLEN dlen;
if (SvROK(check_sv)) {
/* croak("UTF-8 decoder doesn't support callback CHECK"); */
SvPOK_only(dst);
SvCUR_set(dst,0);
+ dlen = (s && e && s < e) ? e-s+1 : 1;
+ d = (U8 *) SvGROW(dst, dlen);
+
while (s < e) {
if (UTF8_IS_INVARIANT(*s)) {
- sv_catpvn(dst, (char *)s, 1);
- s++;
+ *d++ = *s++;
continue;
}
/* Whole char is good */
- sv_catpvn(dst,(char *)s,skip);
+ memcpy(d, s, skip);
+ d += skip;
s += skip;
continue;
}
if (encode){
SvUTF8_off(subchar); /* make sure no decoded string gets in */
}
+ dlen += SvCUR(subchar) - ulen;
+ SvCUR_set(dst, d-(U8 *)SvPVX(dst));
+ *SvEND(dst) = '\0';
sv_catsv(dst, subchar);
SvREFCNT_dec(subchar);
+ d = (U8 *) SvGROW(dst, dlen) + SvCUR(dst);
} else {
- sv_catpv(dst, FBCHAR_UTF8);
+ STRLEN fbcharlen = strlen(FBCHAR_UTF8);
+ dlen += fbcharlen - ulen;
+ if (SvLEN(dst) < dlen) {
+ SvCUR_set(dst, d-(U8 *)SvPVX(dst));
+ d = (U8 *) sv_grow(dst, dlen) + SvCUR(dst);
+ }
+ memcpy(d, FBCHAR_UTF8, fbcharlen);
+ d += fbcharlen;
}
s += ulen;
}
+ SvCUR_set(dst, d-(U8 *)SvPVX(dst));
*SvEND(dst) = '\0';
return s;
PROTOTYPES: DISABLE
+#ifndef SvIsCOW
+# define SvIsCOW(sv) (SvREADONLY(sv) && SvFAKE(sv))
+#endif
+
void
Method_decode_xs(obj,src,check_sv = &PL_sv_no)
SV * obj
{
dSP; ENTER; SAVETMPS;
if (src == &PL_sv_undef || SvROK(src)) src = sv_2mortal(newSV(0));
+ check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvIV(check_sv);
+ if (!(check & ENCODE_LEAVE_SRC) && SvIsCOW(src)) {
+ /*
+ * disassociate from any other scalars before doing
+ * in-place modifications
+ */
+ sv_force_normal(src);
+ }
s = (U8 *) SvPV(src, slen);
e = (U8 *) SvEND(src);
- check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvIV(check_sv);
/*
* PerlIO check -- we assume the object is of PerlIO if renewed
*/
int check;
SV *fallback_cb = &PL_sv_undef;
encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ if (SvREADONLY(src) || SvSMAGICAL(src) || SvGMAGICAL(src) || !SvPOK(src)) {
+ SV *tmp;
+ tmp = sv_newmortal();
+ sv_copypv(tmp, src);
+ src = tmp;
+ }
if (SvUTF8(src)) {
- sv_utf8_downgrade(src, FALSE);
+ sv_utf8_downgrade(src, FALSE);
}
if (SvROK(check_sv)){
fallback_cb = check_sv;
XSRETURN(1);
}
+
+#ifndef SvPV_force_nolen
+# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC)
+#endif
+
+#ifndef SvPV_force_flags_nolen
+# define SvPV_force_flags_nolen(sv, flags) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? SvPVX(sv) : sv_pvn_force_flags(sv, &PL_na, flags))
+#endif
+
void
Method_encode(obj,src,check_sv = &PL_sv_no)
SV * obj
int check;
SV *fallback_cb = &PL_sv_undef;
encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+ if (SvREADONLY(src) || SvSMAGICAL(src) || SvGMAGICAL(src) || !SvPOK(src)) {
+ /*
+ SV *tmp;
+ tmp = sv_newmortal();
+ sv_copypv(tmp, src);
+ src = tmp;
+ */
+ src = sv_mortalcopy(src);
+ SvPV_force_nolen(src);
+ }
sv_utf8_upgrade(src);
if (SvROK(check_sv)){
fallback_cb = check_sv;
OUTPUT:
RETVAL
-#ifndef SvIsCOW
-# define SvIsCOW(sv) (SvREADONLY(sv) && SvFAKE(sv))
-#endif
-
SV *
_utf8_on(sv)
SV * sv
#
-# $Id: Makefile.PL,v 2.16 2015/09/24 02:19:21 dankogai Exp $
+# $Id: Makefile.PL,v 2.17 2016/08/04 03:15:58 dankogai Exp $
#
use 5.007003;
use strict;
Exporter => '5.57', # use Exporter 'import';
parent => '0.221', # version bundled with 5.10.1
},
+ TEST_REQUIRES => {
+ 'Test::More' => '0.81_01',
+ },
PMLIBDIRS => \@pmlibdirs,
INSTALLDIRS => ($] < 5.011 ? 'perl' : 'site'),
META_MERGE => {
# with $ENV{PERL_CORE} set
# In case we need it in future...
require Config; import Config;
+ pop @INC if $INC[-1] eq '.';
}
use strict;
use warnings;
use Getopt::Std;
use Config;
my @orig_ARGV = @ARGV;
-our $VERSION = do { my @r = (q$Revision: 2.18 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+our $VERSION = do { my @r = (q$Revision: 2.19 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
# These may get re-ordered.
# RAW is a do_now as inserted by &enter
#!./perl
use 5.008001;
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use warnings;
use Encode;
=head1 VERSION
-$Id: encguess,v 0.1 2015/02/05 10:34:19 dankogai Exp $
+$Id: encguess,v 0.2 2016/08/04 03:15:58 dankogai Exp $
=head1 SYNOPSIS
#!./perl
-# $Id: piconv,v 2.7 2014/05/31 09:48:48 dankogai Exp $
+# $Id: piconv,v 2.8 2016/08/04 03:15:58 dankogai Exp $
#
+BEGIN { pop @INC if $INC[-1] eq '.' }
use 5.8.0;
use strict;
use Encode ;
#!/usr/local/bin/perl
#
-# $Id: ucmlint,v 2.2 2008/03/12 09:51:11 dankogai Exp $
+# $Id: ucmlint,v 2.3 2016/08/04 03:15:58 dankogai Exp $
#
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
-our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+our $VERSION = do { my @r = (q$Revision: 2.3 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
use Getopt::Std;
our %Opt;
#!./perl
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use Encode;
use Getopt::Std;
-# $Id: encoding.pm,v 2.17 2015/09/15 13:53:27 dankogai Exp dankogai $
+# $Id: encoding.pm,v 2.18 2016/08/10 18:08:45 dankogai Exp dankogai $
package encoding;
-our $VERSION = '2.17_01';
+our $VERSION = sprintf "%d.%02d", q$Revision: 2.18 $ =~ /(\d+)/g;
use Encode;
use strict;
${^E_NCODING} = $enc;
}
}
- HAS_PERLIO or return 1;
+ if (! HAS_PERLIO ) {
+ return 1;
+ }
}
else {
- warnings::warnif("deprecate",$deprecate) if $deprecate;
+ warnings::warnif("deprecated",$deprecate) if $deprecate;
defined( ${^ENCODING} ) and undef ${^ENCODING};
undef ${^E_NCODING} if PERL_5_21_7;
}
}
use strict;
-use Test;
+use Test::More;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
find_encoding is_utf8);
my @source = qw(ascii iso8859-1 cp1250);
my @destiny = qw(cp1047 cp37 posix-bc);
my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
-plan test => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256 + 6 + 5;
+plan tests => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256 + 6 + 5 + 2;
+
my $str = join('',map(chr($_),0x20..0x7E));
my $cpy = $str;
-ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
-ok($cpy,$str,"ASCII mangled by translating from iso8859-1 to Unicode");
+is length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong";
+is $cpy,$str,"ASCII mangled by translating from iso8859-1 to Unicode";
$cpy = $str;
-ok(from_to($cpy,'Unicode','iso8859-1'),length($str),"Length wrong");
-ok($cpy,$str,"ASCII mangled by translating from Unicode to iso8859-1");
+is from_to($cpy,'Unicode','iso8859-1'),length($str),"Length wrong";
+is $cpy,$str,"ASCII mangled by translating from Unicode to iso8859-1";
$str = join('',map(chr($_),0xa0..0xff));
$cpy = $str;
-ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
+is length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong";
my $sym = Encode->getEncoding('symbol');
my $uni = $sym->decode(encode(ascii => 'a'));
-ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'");
+is "\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'";
$str = $sym->encode("\N{Beta}");
-ok("B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta");
+is "B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta";
foreach my $enc (qw(symbol dingbats ascii),@encodings)
{
my $tab = Encode->getEncoding($enc);
- ok(1,defined($tab),"Could not load $enc");
+ is 1,defined($tab),"Could not load $enc";
$str = join('',map(chr($_),0x20..0x7E));
$uni = $tab->decode($str);
$cpy = $tab->encode($uni);
- ok($cpy,$str,"$enc mangled translating to Unicode and back");
+ is $cpy,$str,"$enc mangled translating to Unicode and back";
}
# On ASCII based machines see if we can map several codepoints from
my $native_chr = $chr;
my $cpy = $chr;
my $rc = from_to($cpy,$from,$to);
- ok(1,$rc,"Could not translate from $from to $to");
- ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to");
+ is 1,$rc,"Could not translate from $from to $to";
+ is ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to";
}
}
}
$str = chr($ord);
my $rc = from_to($str,$enc_as,$enc_eb);
$rc += from_to($str,$enc_eb,$enc_as);
- ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained");
- ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back");
+ is $rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained";
+ is $ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back";
}
}
my $mime = find_encoding('iso-8859-2');
-ok(defined($mime),1,"Cannot find MIME-ish'iso-8859-2'");
+is defined($mime),1,"Cannot find MIME-ish'iso-8859-2'";
my $x11 = find_encoding('iso8859-2');
-ok(defined($x11),1,"Cannot find X11-ish 'iso8859-2'");
-ok($mime,$x11,"iso8598-2 and iso-8859-2 not same");
+is defined($x11),1,"Cannot find X11-ish 'iso8859-2'";
+is $mime,$x11,"iso8598-2 and iso-8859-2 not same";
my $spc = find_encoding('iso 8859-2');
-ok(defined($spc),1,"Cannot find 'iso 8859-2'");
-ok($spc,$mime,"iso 8859-2 and iso-8859-2 not same");
+is defined($spc),1,"Cannot find 'iso 8859-2'";
+is $spc,$mime,"iso 8859-2 and iso-8859-2 not same";
for my $i (256,128,129,256)
{
my $c = chr($i);
my $s = "$c\n".sprintf("%02X",$i);
- ok(utf8::valid($s),1,"concat of $i botched");
+ is utf8::valid($s),1,"concat of $i botched";
utf8::upgrade($s);
- ok(utf8::valid($s),1,"concat of $i botched");
+ is utf8::valid($s),1,"concat of $i botched";
}
# Spot check a few points in/out of utf8
{
my $c = chr($i);
my $o = encode_utf8($c);
- ok(decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i");
- ok(encode('utf8',$c),$o,"utf8 encode by name broken for $i");
- ok(decode('utf8',$o),$c,"utf8 decode by name broken for $i");
+ is decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i";
+ is encode('utf8',$c),$o,"utf8 encode by name broken for $i";
+ is decode('utf8',$o),$c,"utf8 decode by name broken for $i";
}
my $key = (keys %{{ "whatever\x{100}" => '' }})[0];
my $kopy = $key;
encode("UTF-16LE", $kopy, Encode::FB_CROAK);
-ok $key, "whatever\x{100}", 'encode with shared hash key scalars';
+is $key, "whatever\x{100}", 'encode with shared hash key scalars';
undef $key;
$key = (keys %{{ "whatever" => '' }})[0];
$kopy = $key;
decode("UTF-16LE", $kopy, Encode::FB_CROAK);
-ok $key, "whatever", 'decode with shared hash key scalars';
+is $key, "whatever", 'decode with shared hash key scalars';
+
+my $latin1 = find_encoding('latin1');
+my $orig = "\316";
+$orig =~ /(.)/;
+is $latin1->encode($1), $orig, '[cpan #115168] passing magic regex globals to encode';
+SKIP: {
+ skip "Perl Version ($]) is older than v5.16", 1 if $] < 5.016;
+ *a = $orig;
+ is $latin1->encode(*a), '*main::'.$orig, '[cpan #115168] passing typeglobs to encode';
+}
#
-# $Id: cow.t,v 1.1 2013/08/29 16:47:39 dankogai Exp $
+# $Id: cow.t,v 1.2 2016/08/04 03:15:58 dankogai Exp $
#
use strict;
use Encode ();
-use Test::More tests => 2;
+use Test::More tests => 4;
my %a = ( "L\x{c3}\x{a9}on" => "acme" );
# use Devel::Peek;
# Dump(\%h);
+{ # invalid input to encode/decode/from_to should not affect COW-shared scalars
+ my $x = Encode::decode('UTF-8', "\303\244" x 4);
+ my $orig = "$x"; # non-COW copy
+ is($x, $orig, "copy of original string matches");
+ { my $y = $x; Encode::from_to($y, "UTF-8", "iso-8859-1"); }
+ is($x, $orig, "original scalar unmodified after from_to() call");
+}
#
-# $Id: decode.t,v 1.1 2013/08/29 16:47:39 dankogai Exp $
+# $Id: decode.t,v 1.2 2016/08/04 03:15:58 dankogai Exp $
#
use strict;
-use Encode qw(decode_utf8 FB_CROAK);
-use Test::More tests => 3;
+use Encode qw(decode_utf8 FB_CROAK find_encoding decode);
+use Test::More tests => 5;
sub croak_ok(&) {
my $code = shift;
chop(my $new = $bytes . $pad);
croak_ok { Encode::decode_utf8($new, FB_CROAK) };
+my $latin1 = find_encoding('latin1');
+$orig = "\N{U+0080}";
+$orig =~ /(.)/;
+is($latin1->decode($1), $orig, '[cpan #115168] passing magic regex globals to decode');
+SKIP: {
+ skip "Perl Version ($]) is older than v5.16", 1 if $] < 5.016;
+ *a = $orig;
+ is($latin1->decode(*a), '*main::'.$orig, '[cpan #115168] passing typeglobs to decode');
+}
-# $Id: enc_data.t,v 2.2 2013/02/18 02:23:56 dankogai Exp $
+# $Id: enc_data.t,v 2.3 2016/08/10 18:08:45 dankogai Exp dankogai $
BEGIN {
require Config; import Config;
-# $Id: enc_eucjp.t,v 2.2 2013/02/18 02:23:56 dankogai Exp $
+# $Id: enc_eucjp.t,v 2.3 2016/08/10 18:08:45 dankogai Exp dankogai $
# This is the twin of enc_utf8.t .
BEGIN {
-# $Id: enc_module.t,v 2.2 2013/02/18 02:23:56 dankogai Exp $
+# $Id: enc_module.t,v 2.3 2016/08/10 18:08:45 dankogai Exp dankogai $
# This file is in euc-jp
BEGIN {
require Config; import Config;
-# $Id: enc_utf8.t,v 2.2 2013/02/18 02:23:56 dankogai Exp $
+# $Id: enc_utf8.t,v 2.3 2016/08/10 18:08:45 dankogai Exp dankogai $
# This is the twin of enc_eucjp.t .
BEGIN {
#
-# $Id: jperl.t,v 2.2 2013/02/18 02:23:56 dankogai Exp $
+# $Id: jperl.t,v 2.3 2016/08/10 18:08:45 dankogai Exp dankogai $
#
# This script is written in euc-jp
#
-# $Id: mime-header.t,v 2.12 2016/04/11 07:17:02 dankogai Exp dankogai $
+# $Id: mime-header.t,v 2.12 2016/04/11 07:17:02 dankogai Exp $
# This script is written in utf8
#
BEGIN {
}
use Encode;
-use Test::More tests => 7;
+use Test::More tests => 10;
my $valid = "\x61\x00\x00\x00";
my $invalid = "\x78\x56\x34\x12";
is("@warnings", "", "Calling decode in Encode::Unicode on valid string produces no warnings");
}
+
+
{
@warnings = ();
my $ret = Encode::Unicode::decode( $enc, $invalid );
is("@warnings", "", "Warning from decode in Encode::Unicode can be silenced via no warnings");
}
+
+
{
@warnings = ();
my $ret = Encode::decode( $enc, $invalid );
no warnings;
@warnings = ();
my $ret = Encode::decode( $enc, $invalid );
- is("@warnings", "", "Warning from decode in Encode can be silenced via no warnings 'utf8'");
+ is("@warnings", "", "Warning from decode in Encode can be silenced via no warnings");
+};
+
+
+
+{
+ @warnings = ();
+ my $inplace = $invalid;
+ Encode::from_to( $inplace, "UTF32-LE", "UTF-8" );
+ like("@warnings", qr/is not Unicode/, "Calling from_to in Encode on invalid string warns");
+}
+
+{
+ no warnings 'utf8';
+ @warnings = ();
+ my $inplace = $invalid;
+ Encode::from_to( $inplace, "UTF32-LE", "UTF-8" );
+ is("@warnings", "", "Warning from from_to in Encode can be silenced via no warnings 'utf8'");
};
+{
+ no warnings;
+ @warnings = ();
+ my $inplace = $invalid;
+ Encode::from_to( $inplace, "UTF32-LE", "UTF-8" );
+ is("@warnings", "", "Warning from from_to in Encode can be silenced via no warnings");
+};
#!/usr/bin/perl -w
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use IO::File;
use ExtUtils::Packlist;
@ISA = qw(Exporter);
@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
dos2unix);
-$VERSION = '7.18';
+$VERSION = '7.24';
$VERSION = eval $VERSION;
my $Is_VMS = $^O eq 'VMS';
my $vms_efs;
my $vms_case;
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ if (eval { local $SIG{__DIE__};
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require VMS::Feature; }) {
$vms_unix_rpt = VMS::Feature::current("filename_unix_report");
$vms_efs = VMS::Feature::current("efs_charset");
$vms_case = VMS::Feature::current("efs_case_preserve");
our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
warn_if_old_packlist test_s cp_nonempty);
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
my $Is_VMS = $^O eq 'VMS';
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
use File::Spec;
use strict;
use warnings;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
use ExtUtils::MakeMaker::Config;
use strict;
use ExtUtils::MakeMaker::Config;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::Liblist;
package ExtUtils::MM_AIX;
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
package ExtUtils::MM_Any;
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
use Carp;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
if ($Config{useshrplib} eq 'true') {
my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}";
if( $] >= 5.006002 ) {
- $libperl =~ s/a$/dll.a/;
+ $libperl =~ s/(dll\.)?a$/dll.a/;
}
$self->{PERL_ARCHIVE} = $libperl;
} else {
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
our @ISA = qw( ExtUtils::MM_Unix );
}
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
sub new {
use ExtUtils::MakeMaker::Config;
use File::Basename;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
package ExtUtils::MM_QNX;
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
package ExtUtils::MM_UWIN;
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
# If we make $VERSION an our variable parse_version() breaks
use vars qw($VERSION);
-$VERSION = '7.18';
+$VERSION = '7.24';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
require ExtUtils::MM_Any;
$ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
}
- push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $self->xs_obj_opt('$@'), $ldfrom, $libs, $exportlist;
+ push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $ldfrom, $self->xs_obj_opt('$@'), $libs, $exportlist;
%s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \
$(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \
$(INST_DYNAMIC_FIX)
# Make sure perl can find itself before it's installed.
my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE}
- ? $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ?
+ ? ( $self->{PERL_ARCHLIB} && $self->{PERL_LIB} && $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ) ?
q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"}
: undef;
my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB}
my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)';
# 1 2 3 4
- push @m, _sprintf562 <<'EOF', $tmp, $self->xs_obj_opt('$@'), $ldfrom, $makefilename;
+ push @m, _sprintf562 <<'EOF', $tmp, $ldfrom, $self->xs_obj_opt('$@'), $makefilename;
$(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all
$(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS)
$(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call"
use File::Basename;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
package ExtUtils::MM_VOS;
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
$ENV{EMXSHELL} = 'sh'; # to run `commands`
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
use strict;
require ExtUtils::MM;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
our @ISA = qw(ExtUtils::MM);
use File::Path;
my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone
eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') }
- if $CAN_DECODE and $ExtUtils::MakeMaker::Locale::ENCODING_LOCALE eq 'US-ASCII';
+ if $CAN_DECODE and Encode::find_encoding('locale')->name eq 'ascii';
our $Verbose = 0; # exported
our @Parent; # needs to be localized
our %macro_fsentity; # whether a macro is a filesystem name
our %macro_dep; # whether a macro is a dependency
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
# Emulate something resembling CVS $Revision$
execute all matching files in alphabetical order via the
L<Test::Harness> module with the C<-I> switches set correctly.
+You can also organize your tests within subdirectories in the F<t/> directory.
+To do so, use the F<test> directive in your I<Makefile.PL>. For example, if you
+had tests in:
+
+ t/foo
+ t/foo/bar
+
+You could tell make to run tests in both of those directories with the
+following directives:
+
+ test => {TESTS => 't/*/*.t t/*/*/*.t'}
+ test => {TESTS => 't/foo/*.t t/foo/bar/*.t'}
+
+The first will run all test files in all first-level subdirectories and all
+subdirectories they contain. The second will run tests in only the F<t/foo>
+and F<t/foo/bar>.
+
If you'd like to see the raw output of your tests, set the
C<TEST_VERBOSE> variable to true.
use strict;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
use Config ();
package ExtUtils::MakeMaker::FAQ;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
1;
goes through its full installation process which may modify it.
Again, L<local::lib> may assist you here.
+=item How can I organize tests into subdirectories and have them run?
+
+Let's take the following test directory structure:
+
+ t/foo/sometest.t
+ t/bar/othertest.t
+ t/bar/baz/anothertest.t
+
+Now, inside of the C<WriteMakeFile()> function in your F<Makefile.PL>, specify
+where your tests are located with the C<test> directive:
+
+ test => {TESTS => 't/*.t t/*/*.t t/*/*/*.t'}
+
+The first entry in the string will run all tests in the top-level F<t/>
+directory. The second will run all test files located in any subdirectory under
+F<t/>. The third, runs all test files within any subdirectory within any other
+subdirectory located under F<t/>.
+
+Note that you do not have to use wildcards. You can specify explicitly which
+subdirectories to run tests in:
+
+ test => {TESTS => 't/*.t t/foo/*.t t/bar/baz/*.t'}
+
=item PREFIX vs INSTALL_BASE from Module::Build::Cookbook
The behavior of PREFIX is complicated and depends closely on how your
package ExtUtils::MakeMaker::Locale;
use strict;
-our $VERSION = "7.18";
+our $VERSION = "7.24";
$VERSION = eval $VERSION;
use base 'Exporter';
eval {
unless (defined &GetConsoleCP) {
require Win32;
- # no point falling back to Win32::GetConsoleCP from this
- # as added same time, 0.45
- eval { Win32::GetConsoleCP() };
# manually "import" it since Win32->import refuses
- *GetConsoleCP = sub { &Win32::GetConsoleCP } unless $@;
+ *GetConsoleCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
}
unless (defined &GetConsoleCP) {
require Win32::API;
require Win32;
eval { Win32::GetConsoleCP() };
# manually "import" it since Win32->import refuses
- *GetInputCP = sub { &Win32::GetConsoleCP } unless $@;
- *GetOutputCP = sub { &Win32::GetConsoleOutputCP } unless $@;
+ *GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
+ *GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP;
};
unless (defined &GetInputCP) {
eval {
# try Win32::Console module for codepage to use
require Win32::Console;
- eval { Win32::Console::InputCP() };
*GetInputCP = sub { &Win32::Console::InputCP }
- unless $@;
+ if defined &Win32::Console::InputCP;
*GetOutputCP = sub { &Win32::Console::OutputCP }
- unless $@;
+ if defined &Win32::Console::OutputCP;
};
}
unless (defined &GetInputCP) {
package ExtUtils::MakeMaker::Tutorial;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
=item t/
Tests for your modules go here. Each test filename ends with a .t.
-So F<t/foo.t>/ 'make test' will run these tests. The directory is flat,
-you cannot, for example, have t/foo/bar.t run by 'make test'.
+So F<t/foo.t> 'make test' will run these tests.
+
+Typically, the F<t/> test directory is flat, with all test files located
+directly within it. However, you can nest tests within subdirectories, for
+example:
+
+ t/foo/subdir_test.t
+
+To do this, you need to inform C<WriteMakeFile()> in your I<Makefile.PL> file
+in the following fashion:
+
+ test => {TESTS => 't/*.t t/*/*.t'}
+
+That will run all tests in F<t/>, as well as all tests in all subdirectories
+that reside under F<t/>. You can nest as deeply as makes sense for your project.
+Simply add another entry in the test location string. For example, to test:
+
+ t/foo/bar/subdir_test.t
+
+You would use the following C<test> directive:
+
+ test => {TESTS => 't/*.t t/*/*/*.t}
+
+Note that in the above example, tests in the first subdirectory will not be
+run. To run all tests in the intermediary subdirectory preceeding the one
+the test files are in, you need to explicitly note it:
+
+ test => {TESTS => 't/*.t t/*/*.t t/*/*/*.t'}
+
+You don't need to specify wildcards if you only want to test within specific
+subdirectories. The following example will only run tests in F<t/foo>:
+
+ test => {TESTS => 't/foo/*.t'}
Tests are run from the top level of your distribution. So inside a test
you would refer to ./lib to enter the lib directory, for example.
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
-$VERSION = '7.18';
+$VERSION = '7.24';
$VERSION = eval $VERSION;
$CLASS = 'version';
use vars qw($VERSION $CLASS $STRICT $LAX);
-$VERSION = '7.18';
+$VERSION = '7.24';
$VERSION = eval $VERSION;
#--------------------------------------------------------------------------#
# There's just too much Dynaloader incest here to turn on strict vars.
use strict 'refs';
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(&Mksymlists);
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
sub Mksymlists {
use strict;
use warnings;
-our $VERSION = '7.18';
+our $VERSION = '7.24';
$VERSION = eval $VERSION;
use Cwd;
);
# avoid environment variables interfering with our make runs
+delete @ENV{qw(PERL_JSON_BACKEND CPAN_META_JSON_BACKEND PERL_YAML_BACKEND)} if $ENV{PERL_CORE};
delete @ENV{qw(LIB MAKEFLAGS PERL_CORE)};
my $perl = which_perl();
);
# avoid environment variables interfering with our make runs
+delete @ENV{qw(PERL_JSON_BACKEND CPAN_META_JSON_BACKEND PERL_YAML_BACKEND)} if $ENV{PERL_CORE};
delete @ENV{qw(LIB MAKEFLAGS PERL_CORE)};
my $perl = which_perl();
$FTP_PASSIVE $TIMEOUT $DEBUG $WARN $FORCEIPV4
];
-$VERSION = '0.48';
+$VERSION = '0.52';
$VERSION = eval $VERSION; # avoid warnings with development releases
$PREFER_BIN = 0; # XXX TODO implement
$FROM_EMAIL = 'File-Fetch@example.com';
### methods available to fetch the file depending on the scheme
$METHODS = {
http => [ qw|lwp httptiny wget curl lftp fetch httplite lynx iosock| ],
+ https => [ qw|lwp wget curl| ],
ftp => [ qw|lwp netftp wget curl lftp fetch ncftp ftp| ],
file => [ qw|lwp lftp file| ],
rsync => [ qw|rsync| ],
local $Module::Load::Conditional::VERBOSE = 0;
local $Module::Load::Conditional::VERBOSE = 0;
+### Fix CVE-2016-1238 ###
+local $Module::Load::Conditional::FORCE_SAFE_INC = 1;
+
### see what OS we are on, important for file:// uris ###
use constant ON_WIN => ($^O eq 'MSWin32');
use constant ON_VMS => ($^O eq 'VMS');
path => { default => '/' },
file => { required => 1 },
uri => { required => 1 },
+ userinfo => { default => '' },
vol => { default => '' }, # windows for file:// uris
share => { default => '' }, # windows for file:// uris
file_default => { default => 'file_default' },
} else {
### using anything but qw() in hash slices may produce warnings
### in older perls :-(
- @{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s;
+ @{$href}{ qw(userinfo host path) } = $uri =~ m|(?:([^\@:]*:[^\:\@]*)@)?([^/]*)(/.*)$|s;
}
### split the path into file + dir ###
};
+ if ($self->scheme eq 'https') {
+ $use_list->{'LWP::Protocol::https'} = '0';
+ }
+
unless( can_load( modules => $use_list ) ) {
$METHOD_FAIL->{'lwp'} = 1;
return;
### special rules apply for file:// uris ###
$uri->scheme( $self->scheme );
$uri->host( $self->scheme eq 'file' ? '' : $self->host );
- $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
+
+ if ($self->userinfo) {
+ $uri->userinfo($self->userinfo);
+ } elsif ($self->scheme ne 'file') {
+ $uri->userinfo("anonymous:$FROM_EMAIL");
+ }
### set up the useragent object
my $ua = LWP::UserAgent->new();
### modules required to download with lwp ###
my $use_list = {
'HTTP::Lite' => '2.2',
-
+ 'MIME::Base64' => '0',
};
unless( can_load(modules => $use_list) ) {
$http->{timeout} = $TIMEOUT if $TIMEOUT;
$http->http11_mode(1);
+ if ($self->userinfo) {
+ my $encoded = MIME::Base64::encode($self->userinfo, '');
+ $http->add_req_header("Authorization", "Basic $encoded");
+ }
+
my $fh = FileHandle->new;
unless ( $fh->open($to,'>') ) {
for what schemes, if available:
file => LWP, lftp, file
- http => LWP, HTTP::Lite, wget, curl, lftp, fetch, lynx, iosock
+ http => LWP, HTTP::Tiny, wget, curl, lftp, fetch, HTTP::Lite, lynx, iosock
ftp => LWP, Net::FTP, wget, curl, lftp, fetch, ncftp, ftp
rsync => rsync
git => git
path => '/CPAN/',
file => 'MIRRORING.FROM',
},
- { uri => 'git://github.com/jib/file-fetch.git',
+ { uri => 'git://github.com/Perl-Toolchain-Gang/file-fetch.git',
scheme => 'git',
host => 'github.com',
- path => '/jib/',
+ path => '/Perl-Toolchain-Gang/',
file => 'file-fetch.git',
},
{ uri => 'http://localhost/tmp/index.txt',
### Heuristics
{
require IO::Socket::INET;
- my $sock = IO::Socket::INET->new( PeerAddr => 'ftp.funet.fi', PeerPort => 21, Timeout => 20 )
+ my $sock = IO::Socket::INET->new( PeerAddr => 'mirror.bytemark.co.uk', PeerPort => 21, Timeout => 20 )
or $heuristics{ftp} = 0;
}
### ftp:// tests ###
-{ my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html';
- for (qw[lwp netftp wget curl lftp fetch ncftp]) {
+{ my $uri = 'ftp://mirror.bytemark.co.uk/CPAN/index.html';
+ for (qw[wget curl lftp fetch ncftp]) {
### STUPID STUPID warnings ###
next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE
{ for my $uri ( 'http://www.cpan.org/index.html',
'http://www.cpan.org/index.html?q=1',
'http://www.cpan.org/index.html?q=1&y=2',
+ #'http://user:passwd@httpbin.org/basic-auth/user/passwd',
) {
for (qw[lwp httptiny wget curl lftp fetch lynx httplite iosock]) {
_fetch_uri( http => $uri, $_ );
}
### git:// tests ###
-{ my $uri = 'git://github.com/jib/file-fetch.git';
+{ my $uri = 'git://github.com/Perl-Toolchain-Gang/file-fetch.git';
for (qw[git]) {
+ local $ENV{GIT_CONFIG_NOSYSTEM} = 1;
+ local $ENV{XDG_CONFIG_HOME};
+ local $ENV{HOME};
_fetch_uri( git => $uri, $_ );
}
}
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
-our $VERSION = '0.058';
+our $VERSION = '0.064';
use Carp ();
my $self = {
max_redirect => 5,
- timeout => 60,
+ timeout => defined $args{timeout} ? $args{timeout} : 60,
keep_alive => 1,
verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
no_proxy => $ENV{no_proxy},
my ($self, $url, $file, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
+
+ if ( exists $args->{headers} ) {
+ my $headers = {};
+ while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
+ $headers->{lc $key} = $value;
+ }
+ $args->{headers} = $headers;
+ }
+
if ( -e $file and my $mtime = (stat($file))[9] ) {
$args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
}
my($ok, $reason) = (1, '');
# Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
unless (eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}) {
$ok = 0;
$reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/;
$self->write($chunk);
}
$self->write("0\x0D\x0A");
- $self->write_header_lines($request->{trailer_cb}->())
- if ref $request->{trailer_cb} eq 'CODE';
+ if ( ref $request->{trailer_cb} eq 'CODE' ) {
+ $self->write_header_lines($request->{trailer_cb}->())
+ }
+ else {
+ $self->write("\x0D\x0A");
+ }
return $len;
}
return $ca_file;
}
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
return Mozilla::CA::SSL_ca_file()
if eval { require Mozilla::CA; 1 };
=head1 VERSION
-version 0.058
+version 0.064
=head1 SYNOPSIS
=head1 CONTRIBUTORS
-=for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley David Golden Dean Pearce Edward Zborowski James Raspass Jeremy Mates Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Olaf Alders Olivier Mengué Petr Písař SkyMarshal Sören Kornetzki Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook
+=for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley David Golden Dean Pearce Edward Zborowski James Raspass Jeremy Mates Jess Robinson Karen Etheridge Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Olaf Alders Olivier Mengué Petr Písař SkyMarshal Sören Kornetzki Steve Grazzini Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook
=over 4
=item *
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
Lukas Eklund <leklund@gmail.com>
=item *
=item *
+Steve Grazzini <steve.grazzini@grantstreet.com>
+
+=item *
+
Syohei YOSHIDA <syohex@gmail.com>
=item *
use warnings;
use Test::More;
-use t::Util qw[tmpfile monkey_patch set_socket_source];
+use lib 't';
+use Util qw[tmpfile monkey_patch set_socket_source];
use HTTP::Tiny;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use HTTP::Tiny;
+
+# Just make sure timeout is handled correctly as a constructor param,
+# and that it works as expected as an "attribute".
+
+my $default = 60;
+
+{
+ my $ua = HTTP::Tiny->new();
+ is $ua->timeout, $default, 'default timeout is as expected';
+}
+
+{
+ my $ua = HTTP::Tiny->new(timeout => 10);
+ is $ua->timeout, 10, 'timeout is handled as a constructor param';
+}
+
+{
+ my $ua = HTTP::Tiny->new(timeout => 0);
+ is $ua->timeout, 0, 'constructor arg of timeout=0 is passed through';
+}
+
+{
+ my $ua = HTTP::Tiny->new(timeout => undef);
+ is $ua->timeout, $default, 'constructor arg of timeout=undef is ignored';
+}
+
+{
+ my $ua = HTTP::Tiny->new();
+ $ua->timeout(15);
+ is $ua->timeout, 15, 'timeout works as expected as a r/w attribute';
+}
use warnings;
use Test::More qw[no_plan];
-use t::Util qw[tmpfile rewind $CRLF $LF];
+use lib 't';
+use Util qw[tmpfile rewind $CRLF $LF];
use HTTP::Tiny;
{
use warnings;
use Test::More qw[no_plan];
-use t::Util qw[tmpfile rewind $CRLF $LF];
+use lib 't';
+use Util qw[tmpfile rewind $CRLF $LF];
use HTTP::Tiny;
sub _header {
use warnings;
use Test::More qw[no_plan];
-use t::Util qw[tmpfile rewind $CRLF $LF];
+use lib 't';
+use Util qw[tmpfile rewind $CRLF $LF];
use HTTP::Tiny;
{
use warnings;
use Test::More qw[no_plan];
-use t::Util qw[tmpfile rewind $CRLF];
+use lib 't';
+use Util qw[tmpfile rewind $CRLF];
use HTTP::Tiny;
{
}
{
- my $body = join($CRLF, map { sprintf('%x', length $_) . $CRLF . $_ } 'A'..'Z', '') . $CRLF;
- my $fh = tmpfile($body);
+ my $fh = tmpfile();
my $handle = HTTP::Tiny::Handle->new(fh => $fh);
- my $exp = ['A'..'Z'];
- my $got = [];
- my $cb = sub { push @$got, $_[0] };
- my $response = { headers => {} };
- $handle->read_chunked_body($cb, $response);
- is_deeply($response->{headers}, {}, 'chunked trailers');
- is_deeply($got, $exp, "chunked chunks");
+
+ my $exp = ['A'..'Z'];
+ my $got = [];
+
+ {
+ my @chunks = @$exp;
+ my $request = {
+ cb => sub { shift @chunks },
+ };
+ $handle->write_chunked_body($request);
+ }
+
+ rewind($fh);
+
+ {
+ my $cb = sub { push @$got, $_[0] };
+ my $response = { headers => {} };
+ $handle->read_chunked_body($cb, $response);
+ }
+
+ is_deeply($got, $exp, "roundtrip chunked chunks w/o trailers");
}
{
is_deeply($response->{headers}, $trailers, 'roundtrip chunked trailers');
}
- is_deeply($got, $exp, "roundtrip chunked chunks");
+ is_deeply($got, $exp, "roundtrip chunked chunks (with trailers)");
}
use warnings;
use Test::More tests => 4;
-use t::SimpleCookieJar;
-use t::BrokenCookieJar;
+use lib 't';
+use SimpleCookieJar;
+use BrokenCookieJar;
use HTTP::Tiny;
### a couple tests to ensure that:
my $default = undef;
-my $jar = t::SimpleCookieJar->new();
-my $mug = t::BrokenCookieJar->new();
-my $dog = t::BrokenCookieJar2->new();
+my $jar = SimpleCookieJar->new();
+my $mug = BrokenCookieJar->new();
+my $dog = BrokenCookieJar2->new();
{
my $ua = HTTP::Tiny->new();
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
hashify connect_args set_socket_source sort_headers $CRLF $LF];
use HTTP::Tiny;
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
set_socket_source sort_headers $CRLF $LF];
use HTTP::Tiny;
BEGIN { monkey_patch() }
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
set_socket_source sort_headers $CRLF $LF];
use HTTP::Tiny;
BEGIN { monkey_patch() }
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
set_socket_source sort_headers $CRLF $LF];
use HTTP::Tiny;
BEGIN { monkey_patch() }
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
set_socket_source sort_headers $CRLF $LF];
use HTTP::Tiny;
BEGIN { monkey_patch() }
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
set_socket_source sort_headers $CRLF $LF];
use HTTP::Tiny;
use File::Temp qw/tempdir/;
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
hashify connect_args clear_socket_source set_socket_source sort_headers
$CRLF $LF];
use File::Basename;
use Test::More 0.88;
-use t::Util qw[ monkey_patch ];
+use lib 't';
+use Util qw[ monkey_patch ];
use HTTP::Tiny;
BEGIN {
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
set_socket_source sort_headers $CRLF $LF];
use HTTP::Tiny;
BEGIN { monkey_patch() }
for my $file ( dir_list("corpus", qr/^form/ ) ) {
my $data = do { local (@ARGV,$/) = $file; <> };
+ $data =~ s/$CRLF/$LF/gm if $^O eq 'MSWin32';
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
# cleanup source data
my $version = HTTP::Tiny->VERSION || 0;
use File::Basename;
use Test::More 0.96;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
hashify connect_args clear_socket_source set_socket_source sort_headers
$CRLF $LF];
use HTTP::Tiny;
BEGIN { monkey_patch() }
-SKIP: for my $class ( qw/t::SimpleCookieJar HTTP::CookieJar/ ) {
+SKIP: for my $class ( qw/SimpleCookieJar HTTP::CookieJar/ ) {
subtest $class => sub {
eval "require $class; 1"
my $data = do { local (@ARGV,$/) = $file; <> };
my @cases = split /--+\n/, $data;
- my $jar = t::SimpleCookieJar->new();
+ my $jar = SimpleCookieJar->new();
my $http = undef;
while (@cases) {
my ($params, $expect_req, $give_res) = splice( @cases, 0, 3 );
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
hashify connect_args clear_socket_source set_socket_source sort_headers
$CRLF $LF];
use File::Basename;
use Test::More 0.88;
-use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
+use lib 't';
+use Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
hashify connect_args clear_socket_source set_socket_source sort_headers
$CRLF $LF];
use warnings;
use File::Basename;
use Test::More 0.88;
-use t::Util qw[
+use lib 't';
+use Util qw[
tmpfile monkey_patch dir_list clear_socket_source set_socket_source
$CRLF
];
-package t::BrokenCookieJar;
+package BrokenCookieJar;
use strict;
use warnings;
return bless {} => $class;
}
-package t::BrokenCookieJar2;
+package BrokenCookieJar2;
use strict;
use warnings;
-package t::SimpleCookieJar;
+package SimpleCookieJar;
use strict;
use warnings;
-package t::Util;
+package Util;
use strict;
use warnings;
# Display info on the contents of a Zip file
#
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use warnings ;
use bytes ;
our ($VERSION, $XS_VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
use Compress::Raw::Bzip2 2.069 ;
our ($VERSION);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
sub mkCompObject
{
require Exporter;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, @EXPORT, %DEFLATE_CONSTANTS);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
@ISA = qw(Exporter);
@EXPORT_OK = @Compress::Raw::Zlib::DEFLATE_CONSTANTS;
%EXPORT_TAGS = %Compress::Raw::Zlib::DEFLATE_CONSTANTS;
use IO::Compress::Base::Common 2.069 qw(:Status);
our ($VERSION);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
sub mkCompObject
{
our (@ISA, $VERSION);
@ISA = qw(Exporter IO::File);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
#Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16.
require Exporter;
our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
@ISA = qw(Exporter);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
@EXPORT = qw( isaFilehandle isaFilename isaScalar
whatIsInput whatIsOutput
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$Bzip2Error = '';
@ISA = qw(Exporter IO::Compress::Base);
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $DeflateError);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$DeflateError = '';
@ISA = qw(Exporter IO::Compress::RawDeflate);
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $GzipError);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$GzipError = '' ;
@ISA = qw(Exporter IO::Compress::RawDeflate);
our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names);
our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
@ISA = qw(Exporter);
our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$RawDeflateError = '';
@ISA = qw(Exporter IO::Compress::Base);
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $ZipError);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$ZipError = '';
@ISA = qw(Exporter IO::Compress::RawDeflate);
our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
@ISA = qw(Exporter);
our ($VERSION, @ISA, @EXPORT);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
@ISA = qw(Exporter);
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
use IO::Compress::Gzip::Constants 2.069 ;
use Compress::Raw::Bzip2 2.069 ;
our ($VERSION, @ISA);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
sub mkUncompObject
{
our ($VERSION);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
use Compress::Raw::Zlib 2.069 ();
use Compress::Raw::Zlib 2.069 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS);
our ($VERSION);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$AnyInflateError = '';
@ISA = qw( Exporter IO::Uncompress::Base );
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$AnyUncompressError = '';
@ISA = qw( Exporter IO::Uncompress::Base );
BEGIN
{
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
eval ' use IO::Uncompress::Adapter::Inflate 2.069 ;';
eval ' use IO::Uncompress::Adapter::Bunzip2 2.069 ;';
eval ' use IO::Uncompress::Adapter::LZO 2.069 ;';
@ISA = qw(Exporter IO::File);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
use constant G_EOF => 0 ;
use constant G_ERR => -1 ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$Bunzip2Error = '';
@ISA = qw( Exporter IO::Uncompress::Base );
$GunzipError = '';
-$VERSION = '2.069';
+$VERSION = '2.069_01';
sub new
{
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$InflateError = '';
@ISA = qw( Exporter IO::Uncompress::RawInflate );
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$RawInflateError = '';
@ISA = qw( Exporter IO::Uncompress::Base );
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup);
-$VERSION = '2.069';
+$VERSION = '2.069_01';
$UnzipError = '';
@ISA = qw(Exporter IO::Uncompress::RawInflate);
# $VERSION needs to be set before use base 'IO::Socket'
# - https://rt.cpan.org/Ticket/Display.html?id=92107
BEGIN {
- $VERSION = '0.37';
+ $VERSION = '0.38';
}
use strict;
If true, set the C<SO_BROADCAST> sockopt
+=item Sockopts => ARRAY
+
+An optional array of other socket options to apply after the three listed
+above. The value is an ARRAY containing 2- or 3-element ARRAYrefs. Each inner
+array relates to a single option, giving the level and option name, and an
+optional value. If the value element is missing, it will be given the value of
+a platform-sized integer 1 constant (i.e. suitable to enable most of the
+common boolean options).
+
+For example, both options given below are equivalent to setting C<ReuseAddr>.
+
+ Sockopts => [
+ [ SOL_SOCKET, SO_REUSEADDR ],
+ [ SOL_SOCKET, SO_REUSEADDR, pack( "i", 1 ) ],
+ ]
+
=item V6Only => BOOL
If defined, set the C<IPV6_V6ONLY> sockopt when creating C<PF_INET6> sockets
}
}
+ my $INT_1 = pack "i", 1;
+
my @sockopts_enabled;
- push @sockopts_enabled, SO_REUSEADDR if $arg->{ReuseAddr};
- push @sockopts_enabled, SO_REUSEPORT if $arg->{ReusePort};
- push @sockopts_enabled, SO_BROADCAST if $arg->{Broadcast};
+ push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEADDR, $INT_1 ] if $arg->{ReuseAddr};
+ push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEPORT, $INT_1 ] if $arg->{ReusePort};
+ push @sockopts_enabled, [ SOL_SOCKET, SO_BROADCAST, $INT_1 ] if $arg->{Broadcast};
+
+ if( my $sockopts = $arg->{Sockopts} ) {
+ ref $sockopts eq "ARRAY" or croak "Expected 'Sockopts' to be an ARRAY ref";
+ foreach ( @$sockopts ) {
+ ref $_ eq "ARRAY" or croak "Bad Sockopts item - expected ARRAYref";
+ @$_ >= 2 and @$_ <= 3 or
+ croak "Bad Sockopts item - expected 2 or 3 elements";
+
+ my ( $level, $optname, $value ) = @$_;
+ # TODO: consider more sanity checking on argument values
+
+ defined $value or $value = $INT_1;
+ push @sockopts_enabled, [ $level, $optname, $value ];
+ }
+ }
my $blocking = $arg->{Blocking};
defined $blocking or $blocking = 1;
$self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};
foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
- $self->setsockopt( SOL_SOCKET, $sockopt, pack "i", 1 ) or ( $@ = "$!", return undef );
+ my ( $level, $optname, $value ) = @$sockopt;
+ $self->setsockopt( $level, $optname, $value ) or ( $@ = "$!", return undef );
}
if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info->{family} == $AF_INET6 ) {
}
elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) {
# Failed for some other reason
+ $self->blocking( $was_blocking );
return undef;
}
elsif( !$was_blocking ) {
my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1;
if( !select( undef, $vec, $vec, $timeout ) ) {
+ $self->blocking( $was_blocking );
$! = ETIMEDOUT;
return undef;
}
) or die "Cannot socket() - $@";
ok( $sock->getsockopt( SOL_SOCKET, SO_REUSEADDR ), 'SO_REUSEADDR set' );
+
+ $sock = IO::Socket::IP->new(
+ LocalHost => "127.0.0.1",
+ Type => SOCK_STREAM,
+ Listen => 1,
+ Sockopts => [
+ [ SOL_SOCKET, SO_REUSEADDR ],
+ ],
+ ) or die "Cannot socket() - $@";
+
+ ok( $sock->getsockopt( SOL_SOCKET, SO_REUSEADDR ), 'SO_REUSEADDR set via Sockopts' );
}
SKIP: {
$HAVE_MONOTONIC
];
- $VERSION = '0.94';
+ $VERSION = '0.96';
$VERBOSE = 0;
$DEBUG = 0;
$WARN = 1;
use Module::Load::Conditional qw[can_load];
use Locale::Maketext::Simple Style => 'gettext';
+local $Module::Load::Conditional::FORCE_SAFE_INC = 1;
+
=pod
=head1 NAME
#!/usr/bin/perl
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use Getopt::Long;
use B ();
#use Devel::Peek;
-$JSON::PP::VERSION = '2.27400';
+$JSON::PP::VERSION = '2.27400_01';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
package Locale::Maketext::Simple;
-$Locale::Maketext::Simple::VERSION = '0.21';
+$Locale::Maketext::Simple::VERSION = '0.21_01';
use strict;
use 5.005;
my $pkg = join('::', grep { defined and length } $args{Class}, $args{Subclass});
return $Loc{$pkg} if exists $Loc{$pkg};
- eval { require Locale::Maketext::Lexicon; 1 } or return;
+ eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require Locale::Maketext::Lexicon;
+ 1
+ } or return;
$Locale::Maketext::Lexicon::VERSION > 0.20 or return;
eval { require File::Spec; 1 } or return;
# write to mjd-perl-memoize+@plover.com for a license.
package Memoize;
-$VERSION = '1.03';
+$VERSION = '1.03_01';
# Compile-time constants
sub SCALAR () { 0 }
}
my $modulefile = $module . '.pm';
$modulefile =~ s{::}{/}g;
- eval { require $modulefile };
+ eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require $modulefile
+ };
if ($@) {
croak "Memoize: Couldn't load hash tie module `$module': $@; aborting";
}
BEGIN {
use vars qw[ $VERSION @ISA $VERBOSE $CACHE @EXPORT_OK $DEPRECATED
- $FIND_VERSION $ERROR $CHECK_INC_HASH];
+ $FIND_VERSION $ERROR $CHECK_INC_HASH $FORCE_SAFE_INC ];
use Exporter;
@ISA = qw[Exporter];
- $VERSION = '0.64';
+ $VERSION = '0.68';
$VERBOSE = 0;
$DEPRECATED = 0;
$FIND_VERSION = 1;
$CHECK_INC_HASH = 0;
+ $FORCE_SAFE_INC = 0;
@EXPORT_OK = qw[check_install can_load requires];
}
### so scan the dirs
unless( $filename ) {
+ local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
+
DIR: for my $dir ( @INC ) {
my $fh;
}
if ( $DEPRECATED and "$]" >= 5.011 ) {
+ local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
require Module::CoreList;
require Config;
if ( $CACHE->{$mod}->{uptodate} ) {
+ local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
+
if ( $args->{autoload} ) {
my $who = (caller())[0];
eval { autoload_remote $who, $mod };
return undef;
}
+ local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
+
my $lib = join " ", map { qq["-I$_"] } @INC;
my $oneliner = 'print(join(qq[\n],map{qq[BONG=$_]}keys(%INC)),qq[\n])';
my $cmd = join '', qq["$^X" $lib -M$who -e], QUOTE, $oneliner, QUOTE;
The default is 0;
+=head2 $Module::Load::Conditional::FORCE_SAFE_INC
+
+This controls whether C<Module::Load::Conditional> sanitises C<@INC>
+by removing "C<.>". The current default setting is C<0>, but this
+may change in a future release.
+
=head2 $Module::Load::Conditional::CACHE
This holds the cache of the C<can_load> function. If you explicitly
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
# vim:ts=8:sw=2:et:sta:sts=2:tw=78
-package Module::Metadata; # git description: v1.000031-13-g7c061c9
+package Module::Metadata; # git description: v1.000032-7-gb4e8a3f
# ABSTRACT: Gather package and POD information from perl module files
# Adapted from Perl-licensed code originally distributed with
use strict;
use warnings;
-our $VERSION = '1.000032'; # TRIAL
+our $VERSION = '1.000033';
use Carp qw/croak/;
use File::Spec;
=head1 VERSION
-version 1.000032
+version 1.000033
=head1 SYNOPSIS
=head1 CONTRIBUTORS
-=for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Graham Knop Olivier Mengué Tomas Doran Tatsuhiko Miyagawa tokuhirom Peter Rabbitson Steve Hay Josh Jore Craig A. Berry Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass Jerry D. Hedden 'BinGOs' Williams Kent Fredric
+=for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Graham Knop Olivier Mengué Tomas Doran Tatsuhiko Miyagawa tokuhirom Kent Fredric Peter Rabbitson Steve Hay Jerry D. Hedden Craig A. Berry Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass 'BinGOs' Williams Josh Jore
=over 4
=item *
+Kent Fredric <kentnl@cpan.org>
+
+=item *
+
Peter Rabbitson <ribasushi@cpan.org>
=item *
=item *
-Josh Jore <jjore@cpan.org>
+Jerry D. Hedden <jdhedden@cpan.org>
=item *
=item *
+Craig A. Berry <craigberry@mac.com>
+
+=item *
+
David Mitchell <davem@iabyn.com>
=item *
=item *
-Jerry D. Hedden <jdhedden@cpan.org>
-
-=item *
-
Chris 'BinGOs' Williams <chris@bingosnet.co.uk>
=item *
-Kent Fredric <kentnl@cpan.org>
+Josh Jore <jjore@cpan.org>
=back
use Module::Metadata;
BEGIN {
- *fh_from_string = $] < 5.008
+ *fh_from_string = "$]" < 5.008
? require IO::Scalar && sub ($) {
IO::Scalar->new(\$_[0]);
}
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings .= $_ for @_ };
- my $pm_info = Module::Metadata->new_from_file(generate_file(File::Spec->catdir($tmpdir, "Simple${test_num}"), 'Simple.pm', $code));
+ my $pm_info = Module::Metadata->new_from_file(generate_file(File::Spec->catfile($tmpdir, "Simple${test_num}"), 'Simple.pm', $code));
# whenever we drop support for 5.6, we can do this:
# open my $fh, '<', \(encode('UTF-8', $code, Encode::FB_CROAK))
SKIP: {
skip( "No our() support until perl 5.6", (defined $expected_version ? 3 : 2) )
- if $] < 5.006 && $code =~ /\bour\b/;
+ if "$]" < 5.006 && $code =~ /\bour\b/;
skip( "No package NAME VERSION support until perl 5.11.1", (defined $expected_version ? 3 : 2) )
- if $] < 5.011001 && $code =~ /package\s+[\w\:\']+\s+v?[0-9._]+/;
+ if "$]" < 5.011001 && $code =~ /package\s+[\w\:\']+\s+v?[0-9._]+/;
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings .= $_ for @_ };
- my $pm_info = Module::Metadata->new_from_file(generate_file(File::Spec->catdir($tmpdir, "Simple${test_num}"), 'Simple.pm', $code));
+ my $pm_info = Module::Metadata->new_from_file(generate_file(File::Spec->catfile($tmpdir, "Simple${test_num}"), 'Simple.pm', $code));
# whenever we drop support for 5.6, we can do this:
# open my $fh, '<', \(encode('UTF-8', $code, Encode::FB_CROAK))
package NEXT;
-$VERSION = '0.65';
+
use Carp;
use strict;
+use warnings;
use overload ();
+our $VERSION = '0.67';
+
sub NEXT::ELSEWHERE::ancestors
{
my @inlist = shift;
package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
-package EVERY;
+package
+ EVERY;
sub EVERY::ELSEWHERE::buildAUTOLOAD {
my $autoload_name = caller() . '::AUTOLOAD';
}
package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD();
-package EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD();
+package
+ EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD();
1;
=head1 NAME
-NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
-
+NEXT - Provide a pseudo-class NEXT (et al) that allows method redispatch
=head1 SYNOPSIS
use NEXT;
- package A;
- sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
- sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
+ package P;
+ sub P::method { print "$_[0]: P method\n"; $_[0]->NEXT::method() }
+ sub P::DESTROY { print "$_[0]: P dtor\n"; $_[0]->NEXT::DESTROY() }
- package B;
- use base qw( A );
- sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
+ package Q;
+ use base qw( P );
+ sub Q::AUTOLOAD { print "$_[0]: Q AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub Q::DESTROY { print "$_[0]: Q dtor\n"; $_[0]->NEXT::DESTROY() }
- package C;
- sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
- sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
+ package R;
+ sub R::method { print "$_[0]: R method\n"; $_[0]->NEXT::method() }
+ sub R::AUTOLOAD { print "$_[0]: R AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub R::DESTROY { print "$_[0]: R dtor\n"; $_[0]->NEXT::DESTROY() }
- package D;
- use base qw( B C );
- sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
- sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
+ package S;
+ use base qw( Q R );
+ sub S::method { print "$_[0]: S method\n"; $_[0]->NEXT::method() }
+ sub S::AUTOLOAD { print "$_[0]: S AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub S::DESTROY { print "$_[0]: S dtor\n"; $_[0]->NEXT::DESTROY() }
package main;
- my $obj = bless {}, "D";
+ my $obj = bless {}, "S";
- $obj->method(); # Calls D::method, A::method, C::method
- $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
+ $obj->method(); # Calls S::method, P::method, R::method
+ $obj->missing_method(); # Calls S::AUTOLOAD, Q::AUTOLOAD, R::AUTOLOAD
- # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
+ # Clean-up calls S::DESTROY, Q::DESTROY, P::DESTROY, R::DESTROY
=head1 DESCRIPTION
-NEXT.pm adds a pseudoclass named C<NEXT> to any program
+The C<NEXT> module adds a pseudoclass named C<NEXT> to any program
that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
C<m> is redispatched as if the calling method had not originally been found.
+B<Note:> before using this module,
+you should look at L<next::method|https://metacpan.org/pod/mro#next::method>
+in the core L<mro> module.
+C<mro> has been a core module since Perl 5.9.5.
+
In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
left-to-right search of C<$self>'s class hierarchy that resulted in the
original call to C<m>.
ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
A typical use would be in the destructors of a class hierarchy,
-as illustrated in the synopsis above. Each class in the hierarchy
+as illustrated in the SYNOPSIS above. Each class in the hierarchy
has a DESTROY method that performs some class-specific action
and then redispatches the call up the hierarchy. As a result,
-when an object of class
D is destroyed, the destructors of I<all>
+when an object of class
S is destroyed, the destructors of I<all>
its parent classes are called (in depth-first, left-to-right order).
Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
to attempt to redispatch any method that does not have the
same name. For example:
- sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
+ sub S::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
=head2 Enforcing redispatch
E->foo();
then it would print:
-
+
called E::foo
called C::foo
called A::foo
=head2 Invoking all versions of a method with a single call
-Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
+Yet another pseudo-class that C<NEXT> provides is C<EVERY>.
Its behaviour is considerably simpler than that of the C<NEXT> family.
A call to:
which the call to C<EVERY::LAST::Init> in the inherited constructor
then correctly picks up.
+=head1 SEE ALSO
+
+L<mro>
+(in particular L<next::method|https://metacpan.org/pod/mro#next::method>),
+which has been a core module since Perl 5.9.5.
=head1 AUTHOR
=head1 BUGS AND IRRITATIONS
-Because it's a module, not an integral part of the interpreter, NEXT.pm
+Because it's a module, not an integral part of the interpreter, C<NEXT>
has to guess where the surrounding call was found in the method
look-up sequence. In the presence of diamond inheritance patterns
it occasionally guesses wrong.
+++ /dev/null
----\r
-abstract: ~\r
-author:\r
- - 'Olivier Mengué'\r
-build_requires:\r
- ExtUtils::MakeMaker: 6.36\r
-configure_requires:\r
- ExtUtils::MakeMaker: 6.36\r
-distribution_type: module\r
-dynamic_config: 1\r
-generated_by: 'Module::Install version 1.06'\r
-license: perl\r
-meta-spec:\r
- url: http://module-build.sourceforge.net/META-spec-v1.4.html\r
- version: 1.4\r
-name: Foo\r
-no_index:\r
- directory:\r
- - inc\r
-requires:\r
- perl: 5.005\r
-resources:\r
- license: http://dev.perl.org/licenses/\r
-version: 0.01\r
+++ /dev/null
-{
- "abstract" : "Lexical Analyzer for Perl5",
- "author" : [
- "Masaaki Goshima (goccy) <goccy(at)cpan.org>"
- ],
- "dynamic_config" : 0,
- "generated_by" : "Module::Build version 0.4205",
- "license" : [
- "perl_5"
- ],
- "meta-spec" : {
- "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
- "version" : "2"
- },
- "name" : "Compiler-Lexer",
- "no_index" : {
- "directory" : [
- "t",
- "examples",
- "builder"
- ]
- },
- "prereqs" : {
- "build" : {
- "requires" : {
- "ExtUtils::CBuilder" : "0"
- }
- },
- "configure" : {
- "requires" : {
- "Module::Build" : "0.38",
- "Module::Build::XSUtil" : "0.06"
- }
- }
- },
- "provides" : {
- "Compiler::Lexer" : {
- "file" : "lib/Compiler/Lexer.pm",
- "version" : "0.18"
- },
- "Compiler::Lexer::Kind" : {
- "file" : "lib/Compiler/Lexer/Constants.pm"
- },
- "Compiler::Lexer::SyntaxType" : {
- "file" : "lib/Compiler/Lexer/Constants.pm"
- },
- "Compiler::Lexer::Token" : {
- "file" : "lib/Compiler/Lexer/Token.pm"
- },
- "Compiler::Lexer::TokenType" : {
- "file" : "lib/Compiler/Lexer/Constants.pm"
- }
- },
- "release_status" : "stable",
- "resources" : {
- "bugtracker" : {
- "web" : "https://github.com/goccy/p5-Compiler-Lexer/issues"
- },
- "homepage" : "https://github.com/goccy/p5-Compiler-Lexer",
- "repository" : {
- "type" : "git",
- "url" : "git://github.com/goccy/p5-Compiler-Lexer.git"
- }
- },
- "version" : "0.18",
- "x_contributors" : [
- "tokuhirom <tokuhirom@gmail.com>",
- "Reini Urban <rurban@cpanel.net>",
- "Fumihiro Itoh <fmhrit@gmail.com>",
- "Masaaki Goshima <masaaki.goshima@mixi.co.jp>",
- "moznion <moznion@gmail.com>",
- "Olivier Mengué <dolmen@cpan.org>",
- "Masaaki Goshima <goccy54@gmail.com>"
- ]
-}
+++ /dev/null
-{
- "abstract" : "a set of version requirements for a CPAN dist",
- "author" : [
- "Ricardo Signes <rjbs@cpan.org>"
- ],
- "build_requires" : {
- "Test::More" : "0.88"
- },
- "configure_requires" : {
- "ExtUtils::MakeMaker" : "6.31"
- },
- "generated_by" : "Dist::Zilla version 2.100991",
- "license" : "perl",
- "meta-spec" : {
- "url" : "http://module-build.sourceforge.net/META-spec-v1.4.html",
- "version" : 1.4
- },
- "name" : "Version-Requirements",
- "recommends" : {},
- "requires" : {
- "Carp" : "0",
- "Scalar::Util" : "0",
- "version" : "0.77"
- },
- "resources" : {
- "repository" : "git://git.codesimply.com/Version-Requirements.git"
- },
- "version" : "0.101010",
- "x_contributors" : [
- "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>"
- ]
-}
-
+++ /dev/null
----
-abstract: 'a set of version requirements for a CPAN dist'
-author:
- - 'Ricardo Signes <rjbs@cpan.org>'
-build_requires:
- Test::More: 0.88
-configure_requires:
- ExtUtils::MakeMaker: 6.31
-generated_by: 'Dist::Zilla version 2.100991'
-license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Version-Requirements
-recommends: {}
-requires:
- Carp: 0
- Scalar::Util: 0
- version: 0.77
-resources:
- repository: git://git.codesimply.com/Version-Requirements.git
-version: 0.101010
-x_contributors:
- - 'Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>'
+++ /dev/null
-abstract: 'a set of version requirements for a CPAN dist'
-author:
- - 'Ricardo Signes <rjbs@cpan.org>'
-build_requires:
- Test::More: 0.88
-configure_requires:
- ExtUtils::MakeMaker: 6.31
-generated_by: 'Dist::Zilla version 2.100991'
-license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Version-Requirements
-recommends: {}
-requires:
- Carp: 0
- Scalar::Util: 0
- version: 0.77
-resources:
- repository: git://git.codesimply.com/Version-Requirements.git
-version: 0.101010
-x_contributors:
- - 'Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>'
+++ /dev/null
-{
- "abstract" : "a set of version requirements for a CPAN dist",
- "author" : [
- "Ricardo Signes <rjbs@cpan.org>"
- ],
- "build_requires" : {
- "Test::More" : "0.88"
- },
- "configure_requires" : {
- "ExtUtils::MakeMaker" : "6.31"
- },
- "generated_by" : "Dist::Zilla version 2.100991",
- "license" : "perl",
- "meta-spec" : {
- "url" : "http://module-build.sourceforge.net/META-spec-v1.4.html",
- "version" : 1.4
- },
- "name" : "Version-Requirements",
- "recommends" : {},
- "requires" : {
- "Carp" : "0",
- "Scalar::Util" : "0",
- "version" : "0.77"
- },
- "resources" : {
- "repository" : "git://git.codesimply.com/Version-Requirements.git"
- },
- "version" : "0.101010",
- "x_contributors" : [
- "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>"
- ]
-}
-
+++ /dev/null
----
-abstract: 'a set of version requirements for a CPAN dist'
-author:
- - 'Ricardo Signes <rjbs@cpan.org>'
-build_requires:
- Test::More: 0.88
-configure_requires:
- ExtUtils::MakeMaker: 6.31
-generated_by: 'Dist::Zilla version 2.100991'
-license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Version-Requirements
-recommends: {}
-requires:
- Carp: 0
- Scalar::Util: 0
- version: 0.77
-resources:
- repository: git://git.codesimply.com/Version-Requirements.git
-version: 0.101010
-x_contributors:
- - 'Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>'
+++ /dev/null
-use 5.008001;
-use strict;
-package Parse::CPAN::Meta;
-# ABSTRACT: Parse META.yml and META.json CPAN metadata files
-
-our $VERSION = '1.4422';
-
-use Exporter;
-use Carp 'croak';
-
-our @ISA = qw/Exporter/;
-our @EXPORT_OK = qw/Load LoadFile/;
-
-sub load_file {
- my ($class, $filename) = @_;
-
- my $meta = _slurp($filename);
-
- if ($filename =~ /\.ya?ml$/) {
- return $class->load_yaml_string($meta);
- }
- elsif ($filename =~ /\.json$/) {
- return $class->load_json_string($meta);
- }
- else {
- $class->load_string($meta); # try to detect yaml/json
- }
-}
-
-sub load_string {
- my ($class, $string) = @_;
- if ( $string =~ /^---/ ) { # looks like YAML
- return $class->load_yaml_string($string);
- }
- elsif ( $string =~ /^\s*\{/ ) { # looks like JSON
- return $class->load_json_string($string);
- }
- else { # maybe doc-marker-free YAML
- return $class->load_yaml_string($string);
- }
-}
-
-sub load_yaml_string {
- my ($class, $string) = @_;
- my $backend = $class->yaml_backend();
- my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
- croak $@ if $@;
- return $data || {}; # in case document was valid but empty
-}
-
-sub load_json_string {
- my ($class, $string) = @_;
- require Encode;
- # load_json_string takes characters, decode_json expects bytes
- my $encoded = Encode::encode('UTF-8', $string, Encode::PERLQQ());
- my $data = eval { $class->json_decoder()->can('decode_json')->($encoded) };
- croak $@ if $@;
- return $data || {};
-}
-
-sub yaml_backend {
- if (! defined $ENV{PERL_YAML_BACKEND} ) {
- _can_load( 'CPAN::Meta::YAML', 0.011 )
- or croak "CPAN::Meta::YAML 0.011 is not available\n";
- return "CPAN::Meta::YAML";
- }
- else {
- my $backend = $ENV{PERL_YAML_BACKEND};
- _can_load( $backend )
- or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
- $backend->can("Load")
- or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
- return $backend;
- }
-}
-
-sub json_decoder {
- if (my $decoder = $ENV{CPAN_META_JSON_DECODER}) {
- _can_load( $decoder )
- or croak "Could not load CPAN_META_JSON_DECODER '$decoder'\n";
- $decoder->can('decode_json')
- or croak "No decode_json sub provided by CPAN_META_JSON_DECODER '$decoder'\n";
- return $decoder;
- }
- return $_[0]->json_backend;
-}
-
-sub json_backend {
- if (my $backend = $ENV{CPAN_META_JSON_BACKEND}) {
- _can_load( $backend )
- or croak "Could not load CPAN_META_JSON_BACKEND '$backend'\n";
- $backend->can('new')
- or croak "No constructor provided by CPAN_META_JSON_BACKEND '$backend'\n";
- return $backend;
- }
- if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
- _can_load( 'JSON::PP' => 2.27300 )
- or croak "JSON::PP 2.27300 is not available\n";
- return 'JSON::PP';
- }
- else {
- _can_load( 'JSON' => 2.5 )
- or croak "JSON 2.5 is required for " .
- "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
- return "JSON";
- }
-}
-
-sub _slurp {
- require Encode;
- open my $fh, "<:raw", "$_[0]" ## no critic
- or die "can't open $_[0] for reading: $!";
- my $content = do { local $/; <$fh> };
- $content = Encode::decode('UTF-8', $content, Encode::PERLQQ());
- return $content;
-}
-
-sub _can_load {
- my ($module, $version) = @_;
- (my $file = $module) =~ s{::}{/}g;
- $file .= ".pm";
- return 1 if $INC{$file};
- return 0 if exists $INC{$file}; # prior load failed
- eval { require $file; 1 }
- or return 0;
- if ( defined $version ) {
- eval { $module->VERSION($version); 1 }
- or return 0;
- }
- return 1;
-}
-
-# Kept for backwards compatibility only
-# Create an object from a file
-sub LoadFile ($) { ## no critic
- return Load(_slurp(shift));
-}
-
-# Parse a document from a string.
-sub Load ($) { ## no critic
- require CPAN::Meta::YAML;
- my $object = eval { CPAN::Meta::YAML::Load(shift) };
- croak $@ if $@;
- return $object;
-}
-
-1;
-
-__END__
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files
-
-=head1 VERSION
-
-version 1.4422
-
-=head1 SYNOPSIS
-
- #############################################
- # In your file
-
- ---
- name: My-Distribution
- version: 1.23
- resources:
- homepage: "http://example.com/dist/My-Distribution"
-
-
- #############################################
- # In your program
-
- use Parse::CPAN::Meta;
-
- my $distmeta = Parse::CPAN::Meta->load_file('META.yml');
-
- # Reading properties
- my $name = $distmeta->{name};
- my $version = $distmeta->{version};
- my $homepage = $distmeta->{resources}{homepage};
-
-=head1 DESCRIPTION
-
-B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
-L<JSON::PP> and/or L<CPAN::Meta::YAML>.
-
-B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
-and C<load_yaml_string>. These will read and deserialize CPAN metafiles, and
-are described below in detail.
-
-B<Parse::CPAN::Meta> provides a legacy API of only two functions,
-based on the YAML functions of the same name. Wherever possible,
-identical calling semantics are used. These may only be used with YAML sources.
-
-All error reporting is done with exceptions (die'ing).
-
-Note that META files are expected to be in UTF-8 encoding, only. When
-converted string data, it must first be decoded from UTF-8.
-
-=begin Pod::Coverage
-
-
-
-
-=end Pod::Coverage
-
-=head1 METHODS
-
-=head2 load_file
-
- my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');
-
- my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');
-
-This method will read the named file and deserialize it to a data structure,
-determining whether it should be JSON or YAML based on the filename.
-The file will be read using the ":utf8" IO layer.
-
-=head2 load_yaml_string
-
- my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);
-
-This method deserializes the given string of YAML and returns the first
-document in it. (CPAN metadata files should always have only one document.)
-If the source was UTF-8 encoded, the string must be decoded before calling
-C<load_yaml_string>.
-
-=head2 load_json_string
-
- my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);
-
-This method deserializes the given string of JSON and the result.
-If the source was UTF-8 encoded, the string must be decoded before calling
-C<load_json_string>.
-
-=head2 load_string
-
- my $metadata_structure = Parse::CPAN::Meta->load_string($some_string);
-
-If you don't know whether a string contains YAML or JSON data, this method
-will use some heuristics and guess. If it can't tell, it assumes YAML.
-
-=head2 yaml_backend
-
- my $backend = Parse::CPAN::Meta->yaml_backend;
-
-Returns the module name of the YAML serializer. See L</ENVIRONMENT>
-for details.
-
-=head2 json_backend
-
- my $backend = Parse::CPAN::Meta->json_backend;
-
-Returns the module name of the JSON serializer. If C<CPAN_META_JSON_BACKEND>
-is set, this will be whatever that's set to. If not, this will either
-be L<JSON::PP> or L<JSON>. If C<PERL_JSON_BACKEND> is set,
-this will return L<JSON> as further delegation is handled by
-the L<JSON> module. See L</ENVIRONMENT> for details.
-
-=head2 json_decoder
-
- my $decoder = Parse::CPAN::Meta->json_decoder;
-
-Returns the module name of the JSON decoder. Unlike L</json_backend>, this
-is not necessarily a full L<JSON>-style module, but only something that will
-provide a C<decode_json> subroutine. If C<CPAN_META_JSON_DECODER> is set,
-this will be whatever that's set to. If not, this will be whatever has
-been selected as L</json_backend>. See L</ENVIRONMENT> for more notes.
-
-=head1 FUNCTIONS
-
-For maintenance clarity, no functions are exported by default. These functions
-are available for backwards compatibility only and are best avoided in favor of
-C<load_file>.
-
-=head2 Load
-
- my @yaml = Parse::CPAN::Meta::Load( $string );
-
-Parses a string containing a valid YAML stream into a list of Perl data
-structures.
-
-=head2 LoadFile
-
- my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );
-
-Reads the YAML stream from a file instead of a string.
-
-=head1 ENVIRONMENT
-
-=head2 CPAN_META_JSON_DECODER
-
-By default, L<JSON::PP> will be used for deserializing JSON data. If the
-C<CPAN_META_JSON_DECODER> environment variable exists, this is expected to
-be the name of a loadable module that provides a C<decode_json> subroutine,
-which will then be used for deserialization. Relying only on the existence
-of said subroutine allows for maximum compatibility, since this API is
-provided by all of L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS>,
-L<JSON::MaybeXS>, L<JSON::Tiny>, and L<Mojo::JSON>.
-
-=head2 CPAN_META_JSON_BACKEND
-
-By default, L<JSON::PP> will be used for deserializing JSON data. If the
-C<CPAN_META_JSON_BACKEND> environment variable exists, this is expected to
-be the name of a loadable module that provides the L<JSON> API, since
-downstream code expects to be able to call C<new> on this class. As such,
-while L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS> and L<JSON::MaybeXS> will
-work for this, to use L<Mojo::JSON> or L<JSON::Tiny> for decoding requires
-setting L</CPAN_META_JSON_DECODER>.
-
-=head2 PERL_JSON_BACKEND
-
-If the C<CPAN_META_JSON_BACKEND> environment variable does not exist, and if
-C<PERL_JSON_BACKEND> environment variable exists, is true and is not
-"JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
-used to interpret C<PERL_JSON_BACKEND>. If L<JSON> is not installed or is too
-old, an exception will be thrown. Note that at the time of writing, the only
-useful values are 1, which will tell L<JSON> to guess, or L<JSON::XS> - if
-you want to use a newer JSON module, see L</CPAN_META_JSON_BACKEND>.
-
-=head2 PERL_YAML_BACKEND
-
-By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
-the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
-as a module to use for deserialization. The given module must be installed,
-must load correctly and must implement the C<Load()> function or an exception
-will be thrown.
-
-=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
-
-=head1 SUPPORT
-
-=head2 Bugs / Feature Requests
-
-Please report any bugs or feature requests through the issue tracker
-at L<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta/issues>.
-You will be notified automatically of any progress on your issue.
-
-=head2 Source Code
-
-This is open source software. The code repository is available for
-public review and contribution under the terms of the license.
-
-L<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta>
-
- git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git
-
-=head1 AUTHORS
-
-=over 4
-
-=item *
-
-Adam Kennedy <adamk@cpan.org>
-
-=item *
-
-David Golden <dagolden@cpan.org>
-
-=back
-
-=head1 CONTRIBUTORS
-
-=for stopwords Andreas Koenig David Golden Graham Knop Joshua ben Jore Karen Etheridge Matt S Trout Neil Bowers Ricardo Signes Steffen Mueller
-
-=over 4
-
-=item *
-
-Andreas Koenig <andk@cpan.org>
-
-=item *
-
-David Golden <xdg@xdg.me>
-
-=item *
-
-Graham Knop <haarg@haarg.org>
-
-=item *
-
-Joshua ben Jore <jjore@cpan.org>
-
-=item *
-
-Karen Etheridge <ether@cpan.org>
-
-=item *
-
-Matt S Trout <mst@shadowcat.co.uk>
-
-=item *
-
-Neil Bowers <neil@bowers.com>
-
-=item *
-
-Ricardo Signes <rjbs@cpan.org>
-
-=item *
-
-Steffen Mueller <smueller@cpan.org>
-
-=back
-
-=head1 COPYRIGHT AND LICENSE
-
-This software is copyright (c) 2016 by Adam Kennedy and Contributors.
-
-This is free software; you can redistribute it and/or modify it under
-the same terms as the Perl 5 programming language system itself.
-
-=cut
+++ /dev/null
-#!/usr/bin/perl
-
-delete $ENV{PERL_YAML_BACKEND};
-delete $ENV{PERL_JSON_BACKEND};
-delete $ENV{CPAN_META_JSON_BACKEND};
-delete $ENV{CPAN_META_JSON_DECODER};
-
-# Testing of a known-bad file from an editor
-
-use strict;
-BEGIN {
- $| = 1;
- $^W = 1;
-}
-
-use lib 't/lib';
-use File::Spec::Functions ':ALL';
-use Parse::CPAN::Meta;
-use Parse::CPAN::Meta::Test;
-# use Test::More skip_all => 'Temporarily ignoring failing test';
-use Test::More 'no_plan';
-use utf8;
-
-#####################################################################
-# Testing that Perl::Smith config files work
-
-my $want = {
- "abstract" => "a set of version requirements for a CPAN dist",
- "author" => [ 'Ricardo Signes <rjbs@cpan.org>' ],
- "build_requires" => {
- "Test::More" => "0.88"
- },
- "configure_requires" => {
- "ExtUtils::MakeMaker" => "6.31"
- },
- "generated_by" => "Dist::Zilla version 2.100991",
- "license" => "perl",
- "meta-spec" => {
- "url" => "http://module-build.sourceforge.net/META-spec-v1.4.html",
- "version" => 1.4
- },
- "name" => "Version-Requirements",
- "recommends" => {},
- "requires" => {
- "Carp" => "0",
- "Scalar::Util" => "0",
- "version" => "0.77"
- },
- "resources" => {
- "repository" => "git://git.codesimply.com/Version-Requirements.git"
- },
- "version" => "0.101010",
- "x_contributors" => [
- "Dagfinn Ilmari Mannsåker <ilmari\@ilmari.org>",
- ],
-};
-
-my $meta_json = catfile( test_data_directory(), 'META-VR.json' );
-my $meta_yaml = catfile( test_data_directory(), 'META-VR.yml' );
-my $bare_yaml_meta = catfile( test_data_directory(), 'bareyaml.meta' );
-my $bad_yaml_meta = catfile( test_data_directory(), 'BadMETA.yml' );
-my $CL018_yaml_meta = catfile( test_data_directory(), 'CL018_yaml.meta' );
-
-# These test YAML/JSON detection without the typical file name suffix
-my $yaml_meta = catfile( test_data_directory(), 'yaml.meta' );
-my $json_meta = catfile( test_data_directory(), 'json.meta' );
-
-### YAML tests
-{
- local $ENV{PERL_YAML_BACKEND}; # ensure we get CPAN::META::YAML
-
- is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
- my $from_yaml = Parse::CPAN::Meta->load_file( $meta_yaml );
- is_deeply($from_yaml, $want, "load from YAML file results in expected data");
-}
-
-{
- local $ENV{PERL_YAML_BACKEND}; # ensure we get CPAN::META::YAML
-
- note '';
- is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
- my $from_yaml = Parse::CPAN::Meta->load_file( $yaml_meta );
- is_deeply($from_yaml, $want, "load from YAML .meta file results in expected data");
-}
-
-{
- local $ENV{PERL_YAML_BACKEND}; # ensure we get CPAN::META::YAML
-
- note '';
- is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
- my $from_yaml = Parse::CPAN::Meta->load_file( $bare_yaml_meta );
- is_deeply($from_yaml, $want, "load from bare YAML .meta file results in expected data");
-}
-
-{
- local $ENV{PERL_YAML_BACKEND}; # ensure we get CPAN::META::YAML
-
- note '';
- is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
- my $from_yaml = Parse::CPAN::Meta->load_file( $CL018_yaml_meta );
- like($from_yaml->{x_contributors}[5], qr/Olivier Mengu/, "Open question: what to expect from double encoded UTF-8");
-}
-
-{
- local $ENV{PERL_YAML_BACKEND}; # ensure we get CPAN::META::YAML
-
- note '';
- is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
- my $yaml = load_ok( $meta_yaml, $meta_yaml, 100, ":encoding(UTF-8)");
- my $from_yaml = Parse::CPAN::Meta->load_yaml_string( $yaml );
- is_deeply($from_yaml, $want, "load from YAML str results in expected data");
-}
-
-{
- local $ENV{PERL_YAML_BACKEND}; # ensure we get CPAN::META::YAML
-
- note '';
- is(Parse::CPAN::Meta->yaml_backend(), 'CPAN::Meta::YAML', 'yaml_backend(): CPAN::Meta::YAML');
- my @yaml = Parse::CPAN::Meta::LoadFile( $bad_yaml_meta );
- is($yaml[0]{author}[0], 'Olivier Mengu\xE9', "Bad UTF-8 is replaced");
-}
-
-
-SKIP: {
- note '';
- skip "YAML module not installed", 2
- unless eval "require YAML; 1";
- local $ENV{PERL_YAML_BACKEND} = 'YAML';
-
- is(Parse::CPAN::Meta->yaml_backend(), 'YAML', 'yaml_backend(): YAML');
- my $yaml = load_ok( $meta_yaml, $meta_yaml, 100, ":encoding(UTF-8)");
- my $from_yaml = Parse::CPAN::Meta->load_yaml_string( $yaml );
- is_deeply($from_yaml, $want, "load_yaml_string using PERL_YAML_BACKEND");
-}
-
-### JSON tests
-{
- # JSON tests with JSON::PP
- local $ENV{PERL_JSON_BACKEND}; # ensure we get JSON::PP
-
- note '';
- is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
- my $from_json = Parse::CPAN::Meta->load_file( $meta_json );
- is_deeply($from_json, $want, "load from JSON file results in expected data");
-}
-
-{
- # JSON tests with JSON::PP
- local $ENV{PERL_JSON_BACKEND}; # ensure we get JSON::PP
-
- note '';
- is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
- my $from_json = Parse::CPAN::Meta->load_file( $json_meta );
- is_deeply($from_json, $want, "load from JSON .meta file results in expected data");
-}
-
-{
- # JSON tests with JSON::PP
- local $ENV{PERL_JSON_BACKEND}; # ensure we get JSON::PP
-
- note '';
- is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
- my $json = load_ok( $meta_json, $meta_json, 100, "encoding(UTF-8)");
- my $from_json = Parse::CPAN::Meta->load_json_string( $json );
- is_deeply($from_json, $want, "load from JSON str results in expected data");
-}
-
-{
- # JSON tests with JSON::PP, take 2
- local $ENV{PERL_JSON_BACKEND} = 0; # request JSON::PP
-
- note '';
- is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
- my $json = load_ok( $meta_json, $meta_json, 100, ":encoding(UTF-8)");
- my $from_json = Parse::CPAN::Meta->load_json_string( $json );
- is_deeply($from_json, $want, "load_json_string with PERL_JSON_BACKEND = 0");
-}
-
-{
- # JSON tests with JSON::PP, take 3
- local $ENV{PERL_JSON_BACKEND} = 'JSON::PP'; # request JSON::PP
-
- note '';
- is(Parse::CPAN::Meta->json_backend(), 'JSON::PP', 'json_backend(): JSON::PP');
- my $json = load_ok( $meta_json, $meta_json, 100, ":encoding(UTF-8)");
- my $from_json = Parse::CPAN::Meta->load_json_string( $json );
- is_deeply($from_json, $want, "load_json_string with PERL_JSON_BACKEND = 'JSON::PP'");
-}
-
-{
- # JSON tests with fake backend
- { package MyJSONThingy; $INC{'MyJSONThingy.pm'} = __FILE__; require JSON::PP;
- sub decode_json { JSON::PP::decode_json(@_) } }
-
- local $ENV{CPAN_META_JSON_DECODER} = 'MyJSONThingy'; # request fake backend
-
- note '';
- is(Parse::CPAN::Meta->json_decoder(), 'MyJSONThingy', 'json_decoder(): MyJSONThingy');
- my $json = load_ok( $meta_json, $meta_json, 100, ":encoding(UTF-8)");
- my $from_json = Parse::CPAN::Meta->load_json_string( $json );
- is_deeply($from_json, $want, "load_json_string with PERL_JSON_DECODER = 'MyJSONThingy'");
-}
-
-SKIP: {
- note '';
- skip "JSON module version 2.5 not installed", 2
- unless eval "require JSON; JSON->VERSION(2.5); 1";
- local $ENV{PERL_JSON_BACKEND} = 1;
-
- is(Parse::CPAN::Meta->json_backend(), 'JSON', 'json_backend(): JSON');
- my $json = load_ok( $meta_json, $meta_json, 100, ":encoding(UTF-8)");
- my $from_json = Parse::CPAN::Meta->load_json_string( $json );
- is_deeply($from_json, $want, "load_json_string with PERL_JSON_BACKEND = 1");
-}
-
+++ /dev/null
-#!/usr/bin/perl
-
-delete $ENV{PERL_YAML_BACKEND};
-delete $ENV{PERL_JSON_BACKEND};
-
-# Testing of basic document structures
-
-use strict;
-BEGIN {
- $| = 1;
- $^W = 1;
-}
-
-use Test::More tests => 2;
-use Parse::CPAN::Meta ();
-
-my $one = <<'END_YAML';
----
-- foo
-END_YAML
-
-my $two = <<'END_YAML';
----
-- foo
----
-- bar
-END_YAML
-
-my $one_scalar_tiny = Parse::CPAN::Meta::Load( $one );
-my $two_scalar_tiny = Parse::CPAN::Meta::Load( $two );
-
-is_deeply( $one_scalar_tiny, [ 'foo' ], 'one: Parsed correctly' );
-is_deeply( $two_scalar_tiny, [ 'bar' ], 'two: Parsed correctly' );
+++ /dev/null
-#!/usr/bin/perl
-
-delete $ENV{PERL_YAML_BACKEND};
-delete $ENV{PERL_JSON_BACKEND};
-
-# Testing of basic document structures
-
-use strict;
-BEGIN {
- $| = 1;
- $^W = 1;
-}
-
-use Test::More tests => 4;
-use Parse::CPAN::Meta;
-
-
-
-ok not(defined &main::Load), 'Load is not exported';
-ok not(defined &main::Dump), 'Dump is not exported';
-ok not(defined &main::LoadFile), 'LoadFile is not exported';
-ok not(defined &main::DumpFile), 'DumpFile is not exported';
+++ /dev/null
-#!/usr/bin/perl
-
-delete $ENV{PERL_YAML_BACKEND};
-delete $ENV{PERL_JSON_BACKEND};
-
-# Testing of basic document structures
-
-use strict;
-BEGIN {
- $| = 1;
- $^W = 1;
-}
-
-use Test::More tests => 1;
-use Parse::CPAN::Meta ();
-
-my $one = <<'END_YAML';
----
-- foo: - bar
-END_YAML
-
-my $one_scalar_tiny = eval { Parse::CPAN::Meta->load_yaml_string( $one ) };
-like( $@, '/illegal characters/', "error causes exception");
-
+++ /dev/null
-package Parse::CPAN::Meta::Test;
-
-use strict;
-use Test::More ();
-use Parse::CPAN::Meta;
-use File::Spec;
-
-use vars qw{@ISA @EXPORT};
-BEGIN {
- require Exporter;
- @ISA = qw{ Exporter };
- @EXPORT = qw{
- tests yaml_ok yaml_error slurp load_ok
- test_data_directory
- };
-}
-
-sub test_data_directory {
- return( "corpus" );
-}
-
-# 22 tests per call to yaml_ok
-# 4 tests per call to load_ok
-sub tests {
- return ( tests => count(@_) );
-}
-
-sub count {
- my $yaml_ok = shift || 0;
- my $load_ok = shift || 0;
- my $single = shift || 0;
- my $count = $yaml_ok * 3 + $load_ok * 4 + $single;
- return $count;
-}
-
-sub yaml_ok {
- my $string = shift;
- my $array = shift;
- my $name = shift || 'unnamed';
-
- # Does the string parse to the structure
- my $yaml_copy = $string;
- my @yaml = eval { Parse::CPAN::Meta::Load( $yaml_copy ); };
- Test::More::is( $@, '', "$name: Parse::CPAN::Meta parses without error" );
- Test::More::is( $yaml_copy, $string, "$name: Parse::CPAN::Meta does not modify the input string" );
- SKIP: {
- Test::More::skip( "Shortcutting after failure", 1 ) if $@;
- Test::More::is_deeply( \@yaml, $array, "$name: Parse::CPAN::Meta parses correctly" );
- }
-
- # Return true as a convenience
- return 1;
-}
-
-sub yaml_error {
- my $string = shift;
- my $yaml = eval { Parse::CPAN::Meta::Load( $string ); };
- Test::More::like( $@, qr/$_[0]/, "CPAN::Meta::YAML throws expected error" );
-}
-
-sub slurp {
- my $file = shift;
- my $layer = shift;
- $layer = "" unless defined $layer;
- local $/ = undef;
- open my $fh, "<$layer", $file or die "open($file) failed: $!";
- my $source = <$fh>;
- close( $fh ) or die "close($file) failed: $!";
- $source;
-}
-
-sub load_ok {
- my $name = shift;
- my $file = shift;
- my $size = shift;
- my $layer = shift;
- Test::More::ok( -f $file, "Found $name" ) or Test::More::diag("Searched at '$file'");
- Test::More::ok( -r $file, "Can read $name" );
- my $content = slurp( $file, $layer );
- Test::More::ok( (defined $content and ! ref $content), "Loaded $name" );
- Test::More::ok( ($size < length $content), "Content of $name larger than $size bytes" );
- return $content;
-}
-
-1;
use vars qw($VERSION @Pagers $Bindir $Pod2man
$Temp_Files_Created $Temp_File_Lifetime
);
-$VERSION = '3.25_02'; # patched in perl5.git
-$VERSION =~ s/_//;
+$VERSION = '3.27';
#..........................................................................
-m Display module's file in its entirety
-n Specify replacement for groff
-l Display the module's file name
- -F Arguments are file names, not modules
+ -U Don't attempt to drop privs for security
+ -F Arguments are file names, not modules (implies -U)
-D Verbosely describe what's going on
-T Send output to STDOUT without any pager
-d output_filename_to_send_to
my $program_name = $self->program_name;
CORE::die( <<"EOUSAGE" );
-Usage: $program_name [-hVriDtumFXlT] [-n nroffer_program]
+Usage: $program_name [-hVriDtumUFXlT] [-n nroffer_program]
[-d output_filename] [-o output_format] [-M FormatterModule]
[-w formatter_option:option_value] [-L translation_code]
PageName|ModuleName|ProgramName
$self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
$self->opt_o_with('text');
- $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos || $self->is_amigaos
+ $self->opt_o_with('term')
+ unless $self->is_mswin32 || $self->is_dos || $self->is_amigaos
|| !($ENV{TERM} && (
($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
));
$self->options_reading;
$self->pagers_guessing;
$self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
- $self->drop_privs_maybe unless $self->opt_U;
+ $self->drop_privs_maybe unless ($self->opt_U || $self->opt_F);
$self->options_processing;
# Hm, we have @pages and @found, but we only really act on one
my @class_list = @{ $self->{'formatter_classes'} || [] };
$self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list;
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+
my $good_class_found;
foreach my $c (@class_list) {
DEBUG > 4 and print "Trying to load $c...\n";
my $self = shift;
my $lang = shift;
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
my $pack = 'POD2::' . uc($lang);
eval "require $pack";
if ( !$@ && $pack->can('new') ) {
local $_;
while (<$fh>) {
/^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1);
- last if /^=head2 $re/;
+ last if /^=head2 (?:$re|Alphabetical Listing of Perl Functions)/;
}
# Look for our function
last if $found > 1 and $inlist < 2;
}
}
- elsif (/^=item/) {
+ elsif (/^=item|^=back/) {
last if $found > 1 and $inlist < 2;
}
elsif ($found and /^X<[^>]+>/) {
push @pagers, qw( less.exe more.com< );
unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
}
- elsif ( $self->is_amigaos) {
- push @pagers, qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE );
- unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER};
+ elsif ( $self->is_amigaos) {
+ push @pagers, qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE );
+ unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER};
}
else {
if ($self->is_os2) {
# many many corners of the OS don't like it. So we
# have to force it to be "\" to make everyone happy.
- # if we are on an amiga convert unix path to an amiga one
- $output =~ s/^\/(.*)\/(.*)/$1:$2/ if $self->is_amigaos;
+ # if we are on an amiga convert unix path to an amiga one
+ $output =~ s/^\/(.*)\/(.*)/$1:$2/ if $self->is_amigaos;
foreach my $pager (@pagers) {
$self->aside("About to try calling $pager $output\n");
if ($self->is_vms) {
last if system("$pager $output") == 0;
- } elsif($self->is_amigaos) {
+ } elsif($self->is_amigaos) {
last if system($pager, $output) == 0;
} else {
# fix visible escape codes in ToTerm output
# https://bugs.debian.org/758689
local $ENV{LESS} = defined $ENV{LESS} ? "$ENV{LESS} -R" : "-R";
+ # On FreeBSD, the default pager is more.
+ local $ENV{MORE} = defined $ENV{MORE} ? "$ENV{MORE} -R" : "-R";
last if system("$pager \"$output\"") == 0;
}
}
use warnings;
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
use Carp qw(croak carp);
use Config qw(%Config);
*is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux;
*is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux;
*is_openbsd = $^O =~ m/openbsd/ ? \&TRUE : \&FALSE unless defined &is_openbsd;
+ *is_freebsd = $^O =~ m/freebsd/ ? \&TRUE : \&FALSE unless defined &is_freebsd;
*is_bitrig = $^O =~ m/bitrig/ ? \&TRUE : \&FALSE unless defined &is_bitrig;
}
use strict;
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
BEGIN { # Make a DEBUG constant ASAP
*DEBUG = defined( &Pod::Perldoc::DEBUG )
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
sub is_pageable { 1 }
sub write_with_binmode { 0 }
use vars qw(@ISA);
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
# Pick our superclass...
#
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
use File::Spec::Functions qw(catfile);
use Pod::Man 2.18;
sub _roffer_candidates {
my( $self ) = @_;
- if( $self->is_openbsd || $self->is_bitrig ) { qw( mandoc groff nroff ) }
+ if( $self->is_openbsd || $self->is_freebsd || $self->is_bitrig ) { qw( mandoc groff nroff ) }
else { qw( groff nroff mandoc ) }
}
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
# This is unlike ToMan.pm in that it emits the raw nroff source!
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
sub is_pageable { 1 }
sub write_with_binmode { 0 }
use parent qw( Pod::Simple::RTF );
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
sub is_pageable { 0 }
sub write_with_binmode { 0 }
use warnings;
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
use parent qw(Pod::Perldoc::BaseTo);
use warnings;
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
use parent qw(Pod::Perldoc::BaseTo);
use warnings;
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
use parent qw(Pod::Perldoc::BaseTo);
use parent qw( Pod::Simple::XMLOutStream );
use vars qw($VERSION);
-$VERSION = '3.25';
+$VERSION = '3.27';
sub is_pageable { 0 }
sub write_with_binmode { 0 }
=head1 SYNOPSIS
- perldoc [-h] [-D] [-t] [-u] [-m] [-l] [-F]
+ perldoc [-h] [-D] [-t] [-u] [-m] [-l] [-U] [-F]
[-i] [-V] [-T] [-r]
[-d destination_file]
[-o formatname]
=head1 DESCRIPTION
-B<perldoc> looks up a piece of documentation in .pod format that is
-embedded in the perl installation tree or in a perl script, and displays
-it via C<groff -man | $PAGER>. (In addition, if running under HP-UX,
-C<col -x> will be used.) This is primarily used for the documentation for
-the perl library modules.
+B<perldoc> looks up documentation in .pod format that is embedded in the perl
+installation tree or in a perl script, and displays it using a variety of
+formatters. This is primarily used for the documentation for the perl library
+modules.
Your system may also have man pages installed for those modules, in
which case you can probably just use the man(1) command.
Display onB<l>y the file name of the module found.
+=item B<-U>
+
+When running as the superuser, don't attempt drop privileges for security.
+This option is implied with B<-F>.
+
+B<NOTE>: Please see the heading SECURITY below for more information.
+
=item B<-F>
Consider arguments as file names; no search in directories will be performed.
+Implies B<-U> if run as the superuser.
=item B<-f> I<perlfunc>
or nouser's account, or -2 if unavailable. If it cannot relinquish
its privileges, it will not run.
+See the C<-U> option if you do not want this behavior but B<beware>
+that there are significant security risks if you choose to use C<-U>.
+
+Since 3.26, using C<-F> as the superuser also implies C<-U> as opening
+most files and traversing directories requires privileges that are
+above the nobody/nogroup level.
+
=head1 ENVIRONMENT
Any switches in the C<PERLDOC> environment variable will be used before the
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+my @classes = ('Pod::Perldoc', map { "Pod::Perldoc::$_" } qw(
+ BaseTo ToChecker ToNroff ToRtf
+ GetOptsOO ToMan ToPod ToText ToXml
+ ToANSI ToTerm
+) );
+
+if( eval { require Tk; require Tk::Pod; 1 } ) { push @classes, 'Pod::Perldoc::ToTk' }
+else {
+ note "Skip testing Pod::Perldoc::ToTk because there's no Tk";
+ }
+
+plan tests => scalar @classes;
+
+foreach my $class ( @classes ) {
+ require_ok( $class );
+ my $version = do { no strict 'refs'; ${ '$' . $class . '::VERSION' } };
+ note( "$class $version" ) if defined $version
+ }
--- /dev/null
+use Test::More tests => 1;
+
+pass();
+
+__END__
+
+BEGIN {
+ use_ok 'Pod::Perldoc';
+}
+
+{
+ my @out;
+ push @out,
+ "\n\nPerl v",
+ defined($^V) ? sprintf('%vd', $^V) : $],
+ " under $^O ",
+ (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
+ ? ("(Win32::BuildNumber ", &Win32::BuildNumber(), ")") : (),
+ (defined $MacPerl::Version)
+ ? ("(MacPerl version $MacPerl::Version)") : (),
+ "\n"
+ ;
+
+ # Ugly code to walk the symbol tables:
+ my %v;
+ my @stack = (''); # start out in %::
+ my $this;
+ my $count = 0;
+ my $pref;
+ while(@stack) {
+ $this = shift @stack;
+ die "Too many packages?" if ++$count > 1000;
+ next if exists $v{$this};
+ next if $this eq 'main'; # %main:: is %::
+
+ #print "Peeking at $this => ${$this . '::VERSION'}\n";
+
+ if(defined ${$this . '::VERSION'} ) {
+ $v{$this} = ${$this . '::VERSION'}
+ } elsif(
+ defined *{$this . '::ISA'} or defined &{$this . '::import'}
+ or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . "::"})
+ # If it has an ISA, an import, or any subs...
+ ) {
+ # It's a class/module with no version.
+ $v{$this} = undef;
+ } else {
+ # It's probably an unpopulated package.
+ ## $v{$this} = '...';
+ }
+
+ $pref = length($this) ? "$this\::" : '';
+ push @stack, map m/^(.+)::$/ ? "$pref$1" : (), keys %{$this . '::'};
+ #print "Stack: @stack\n";
+ }
+ push @out, " Modules in memory:\n";
+ delete @v{'', '[none]'};
+ foreach my $p (sort {lc($a) cmp lc($b)} keys %v) {
+ $indent = ' ' x (2 + ($p =~ tr/:/:/));
+ push @out, ' ', $indent, $p, defined($v{$p}) ? " v$v{$p};\n" : ";\n";
+ }
+ push @out, sprintf "[at %s (local) / %s (GMT)]\n",
+ scalar(gmtime), scalar(localtime);
+ my $x = join '', @out;
+ $x =~ s/^/#/mg;
+ print $x;
+}
+
+print "# Running",
+ (chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n",
+ "#\n",
+;
+
+print "# \@INC:\n", map("# [$_]\n", @INC), "#\n#\n";
+
+print "# \%INC:\n";
+foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) {
+ print "# [$x] = [", $INC{$x} || '', "]\n";
+}
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-
-my @classes = ('Pod::Perldoc', map { "Pod::Perldoc::$_" } qw(
- BaseTo ToChecker ToNroff ToRtf
- GetOptsOO ToMan ToPod ToText ToXml
- ToANSI ToTerm
-) );
-
-if( eval { require Tk; require Tk::Pod; 1 } ) { push @classes, 'Pod::Perldoc::ToTk' }
-else {
- note "Skip testing Pod::Perldoc::ToTk because there's no Tk";
- }
-
-plan tests => scalar @classes;
-
-foreach my $class ( @classes ) {
- require_ok( $class );
- my $version = do { no strict 'refs'; ${ '$' . $class . '::VERSION' } };
- note( "$class $version" ) if defined $version
- }
{ no strict 'vars';
- $VERSION = '0.34';
+ $VERSION = '0.34_01';
%EXPORT_TAGS = (
standard => [qw(openlog syslog closelog setlogmask)],
sub can_load {
my ($module, $verbose) = @_;
local($SIG{__DIE__}, $SIG{__WARN__}, $@);
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
my $loaded = eval "use $module; 1";
warn $@ if not $loaded and $verbose;
return $loaded
#!/usr/bin/perl -w
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use warnings;
use App::Prove;
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
use constant GOT_TIME_HIRES => do {
eval 'use Time::HiRes qw(time);';
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 METHODS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
use TAP::Object;
use Text::ParseWords qw/shellwords/;
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
# Get the parts of @INC which are changed from the stock list AND
# preserve reordering of stock directories.
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
my $DEFAULT_TAP_VERSION = 12;
my $MAX_TAP_VERSION = 13;
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head2 DESCRIPTION
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
=head1 SYNOPSIS
use base 'TAP::Object';
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
# TODO:
# Handle blessed object syntax
use base 'TAP::Object';
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
=cut
-our $VERSION = '3.36';
+our $VERSION = '3.36_01';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN {
if( $] < 5.008 ) {
my $ctx = $self->ctx;
$ctx->diag(join '' => map {defined($_) ? $_ : 'undef'} @_);
$ctx->release;
+ return 0;
}
my $ctx = $self->ctx;
$ctx->note(join '' => map {defined($_) ? $_ : 'undef'} @_);
$ctx->release;
+ return 0;
}
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) }
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
=head1 NAME
package Test::Builder::Tester;
use strict;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test::Builder;
use Symbol;
package Test::Builder::Tester::Color;
use strict;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
require Test::Builder::Tester;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) }
return warn @_, " at $file line $line\n";
}
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
use strict;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
use vars qw( @ISA @EXPORT );
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
@ISA = qw( Exporter );
package Test::Tester::Capture;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test::Builder;
package Test::Tester::CaptureRunner;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test::Tester::Capture;
package Test::Tester::Delegate;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use vars '$AUTOLOAD';
package Test::use::ok;
use 5.005;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
__END__
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
1;
L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how
C<intercept()> and C<run_subtest()> are implemented.
+=head1 CONTACTING US
+
+Many Test2 developers and users lurk on L<irc://irc.perl.org/#perl>. We also
+have a slack team that can be joined by anyone with an C<@cpan.org> email
+address L<https://perl-test2.slack.com/> If you do not have an C<@cpan.org>
+email you can ask for a slack invite by emailing Chad Granum
+E<lt>exodist@cpan.orgE<gt>.
+
=head1 SOURCE
The source code repository for Test2 can be found at
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
my $INST;
unless defined wantarray;
my $stack = $params{stack} || $STACK;
- my $hub = $params{hub} || @$stack ? $stack->[-1] : $stack->top;
+ my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top);
my $hid = $hub->{hid};
my $current = $CONTEXTS->{$hid};
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test2::Util qw/pkg_to_file/;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Carp qw/confess croak longmess/;
=item you MUST always use the context() sub from Test2::API
Creating your own context via C<< Test2::API::Context->new() >> will almost never
-produce a desirable result. Use C<context()> which is exported by L<Test2>.
+produce a desirable result. Use C<context()> which is exported by L<Test2::API>.
There are a handful of cases where a tool author may want to create a new
context by hand, which is why the C<new> method exists. Unless you really know
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test2::Hub();
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test2::Util::HashBase qw/trace nested in_subtest subtest_id/;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Carp qw/croak/;
use Scalar::Util qw/reftype/;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase;
use Scalar::Util qw/blessed/;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw/diagnostics renderer/;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
my %ADDED;
use warnings;
require PerlIO;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test2::Util::HashBase qw{
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Carp qw/carp croak confess/;
_context_init
_context_release
+ active
count
failed
ended
my $plan = $self->{+_PLAN};
my $count = $self->{+COUNT};
my $failed = $self->{+FAILED};
+ my $active = $self->{+ACTIVE};
# return if NOTHING was done.
- return unless $do_plan || defined($plan) || $count || $failed;
+ return unless $active || $do_plan || defined($plan) || $count || $failed;
unless ($self->{+ENDED}) {
if ($self->{+_FOLLOW_UPS}) {
behavior is triggered by an end block and is used to cull IPC events, and
output the final plan if the plan was 'no_plan'.
+=item $bool = $hub->active
+
+=item $hub->set_active($bool)
+
+These are used to get/set the 'active' attribute. When true this attribute will
+force C<< hub->finalize() >> to take action even if there is no plan, and no
+tests have been run. This flag is useful for plugins that add follow-up
+behaviors that need to run even if no events are seen.
+
=back
=head2 STATE METHODS
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test2::Hub::Interceptor::Terminator();
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
1;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test2::API::Instance;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Carp qw/confess longmess/;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Config qw/%Config/;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Carp qw/croak/;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
require Carp;
use strict;
use warnings;
-our $VERSION = '1.302045';
+our $VERSION = '1.302052';
use Test2::Util qw/get_tid/;
package ok;
-$ok::VERSION = '1.302045';
+$ok::VERSION = '1.302052';
use strict;
use Test::More ();
}->();
+sub {
+ my $hub = Test2::Hub->new();
+ my $ctx = context(hub => $hub);
+ is($ctx->hub,$hub, 'got the hub of context() argument');
+ $ctx->release;
+}->();
+
+
my $sub = sub { };
Test2::API::test2_add_callback_context_acquire($sub);
--- /dev/null
+use Test::More;
+use strict;
+use warnings;
+
+use Test2::API qw/intercept/;
+
+my @returns;
+intercept {
+ push @returns => diag('foo');
+ push @returns => note('foo');
+
+ my $tb = Test::Builder->new;
+ push @returns => $tb->diag('foo');
+ push @returns => $tb->note('foo');
+};
+
+is(@returns, 4, "4 return values");
+is_deeply(\@returns, [0, 0, 0, 0], "All note/diag returns are 0");
+
+done_testing;
package Time::Local;
-require Exporter;
+use strict;
+
use Carp;
use Config;
-use strict;
+use Exporter;
+
+our $VERSION = '1.24';
-use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
-$VERSION = '1.2300';
+use parent 'Exporter';
-@ISA = qw( Exporter );
-@EXPORT = qw( timegm timelocal );
-@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
+our @EXPORT = qw( timegm timelocal );
+our @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
my @MonthDays = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
use constant SECS_PER_DAY => 86400;
my $MaxDay;
-if ($] < 5.012000) {
+if ( $] < 5.012000 ) {
my $MaxInt;
if ( $^O eq 'MacOS' ) {
+
# time_t is unsigned...
$MaxInt = ( 1 << ( 8 * $Config{ivsize} ) ) - 1;
}
}
else {
# recent localtime()'s limit is the year 2**31
- $MaxDay = 365 * (2**31);
+ $MaxDay = 365 * ( 2**31 );
}
# Determine the EPOC day for this machine
my $Epoc = 0;
if ( $^O eq 'vos' ) {
+
# work around posix-977 -- VOS doesn't handle dates in the range
# 1970-1980.
$Epoc = _daygm( 0, 0, 0, 1, 0, 70, 4, 0 );
}
elsif ( $^O eq 'MacOS' ) {
- $MaxDay *=2 if $^O eq 'MacOS'; # time_t unsigned ... quick hack?
- # MacOS time() is seconds since 1 Jan 1904, localtime
- # so we need to calculate an offset to apply later
- $Epoc = 693901;
- $SecOff = timelocal( localtime(0)) - timelocal( gmtime(0) ) ;
+ $MaxDay *= 2 if $^O eq 'MacOS'; # time_t unsigned ... quick hack?
+ # MacOS time() is seconds since 1 Jan 1904, localtime
+ # so we need to calculate an offset to apply later
+ $Epoc = 693901;
+ $SecOff = timelocal( localtime(0) ) - timelocal( gmtime(0) );
$Epoc += _daygm( gmtime(0) );
}
else {
return $_[3] + (
$Cheat{ pack( 'ss', @_[ 4, 5 ] ) } ||= do {
my $month = ( $_[4] + 10 ) % 12;
- my $year = $_[5] + 1900 - int($month / 10);
+ my $year = $_[5] + 1900 - int( $month / 10 );
( ( 365 * $year )
- + int( $year / 4 )
- - int( $year / 100 )
- + int( $year / 400 )
- + int( ( ( $month * 306 ) + 5 ) / 10 )
- )
- - $Epoc;
- }
+ + int( $year / 4 )
+ - int( $year / 100 )
+ + int( $year / 400 )
+ + int( ( ( $month * 306 ) + 5 ) / 10 ) )
+ - $Epoc;
+ }
);
}
sub _timegm {
- my $sec =
- $SecOff + $_[0] + ( SECS_PER_MINUTE * $_[1] ) + ( SECS_PER_HOUR * $_[2] );
+ my $sec
+ = $SecOff + $_[0]
+ + ( SECS_PER_MINUTE * $_[1] )
+ + ( SECS_PER_HOUR * $_[2] );
return $sec + ( SECS_PER_DAY * &_daygm );
}
if $month > 11
or $month < 0;
- my $md = $MonthDays[$month];
+ my $md = $MonthDays[$month];
++$md
if $month == 1 && _is_leap_year( $year + 1900 );
my $days = _daygm( undef, undef, undef, $mday, $month, $year );
- unless ($Options{no_range_check} or abs($days) < $MaxDay) {
- my $msg = '';
+ unless ( $Options{no_range_check} or abs($days) < $MaxDay ) {
+ my $msg = q{};
$msg .= "Day too big - $days > $MaxDay\n" if $days > $MaxDay;
$year += 1900;
- $msg .= "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";
+ $msg
+ .= "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";
croak $msg;
}
- return $sec
- + $SecOff
- + ( SECS_PER_MINUTE * $min )
- + ( SECS_PER_HOUR * $hour )
- + ( SECS_PER_DAY * $days );
+ return
+ $sec + $SecOff
+ + ( SECS_PER_MINUTE * $min )
+ + ( SECS_PER_HOUR * $hour )
+ + ( SECS_PER_DAY * $days );
}
sub _is_leap_year {
}
sub timelocal {
- my $ref_t = &timegm;
+ my $ref_t = &timegm;
my $loc_for_ref_t = _timegm( localtime($ref_t) );
my $zone_off = $loc_for_ref_t - $ref_t
# If this evaluates to true, it means that the value in $loc_t is
# the _second_ hour after a DST change where the local time moves
# backward.
- if ( ! $dst_off &&
- ( ( $ref_t - SECS_PER_HOUR ) - _timegm( localtime( $loc_t - SECS_PER_HOUR ) ) < 0 )
- ) {
+ if (
+ !$dst_off
+ && ( ( $ref_t - SECS_PER_HOUR )
+ - _timegm( localtime( $loc_t - SECS_PER_HOUR ) ) < 0 )
+ ) {
return $loc_t - SECS_PER_HOUR;
}
1;
+# ABSTRACT: Efficiently compute time from local and GMT time
+
__END__
+=pod
+
+=encoding UTF-8
+
=head1 NAME
-Time::Local - efficiently compute time from local and GMT time
+Time::Local - Efficiently compute time from local and GMT time
+
+=head1 VERSION
+
+version 1.24
=head1 SYNOPSIS
- $time = timelocal( $sec, $min, $hour, $mday, $mon, $year );
- $time = timegm( $sec, $min, $hour, $mday, $mon, $year );
+ use Time::Local;
+
+ my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year );
+ my $time = timegm( $sec, $min, $hour, $mday, $mon, $year );
=head1 DESCRIPTION
-This module provides functions that are the inverse of built-in perl
-functions C<localtime()> and C<gmtime()>. They accept a date as a
-six-element array, and return the corresponding C<time(2)> value in
-seconds since the system epoch (Midnight, January 1, 1970 GMT on Unix,
-for example). This value can be positive or negative, though POSIX
-only requires support for positive values, so dates before the
-system's epoch may not work on all operating systems.
+This module provides functions that are the inverse of built-in perl functions
+C<localtime()> and C<gmtime()>. They accept a date as a six-element array, and
+return the corresponding C<time(2)> value in seconds since the system epoch
+(Midnight, January 1, 1970 GMT on Unix, for example). This value can be
+positive or negative, though POSIX only requires support for positive values,
+so dates before the system's epoch may not work on all operating systems.
-It is worth drawing particular attention to the expected ranges for
-the values provided. The value for the day of the month is the actual
-day (ie 1..31), while the month is the number of months since January
-(0..11). This is consistent with the values returned from
-C<localtime()> and C<gmtime()>.
+It is worth drawing particular attention to the expected ranges for the values
+provided. The value for the day of the month is the actual day (i.e. 1..31),
+while the month is the number of months since January (0..11). This is
+consistent with the values returned from C<localtime()> and C<gmtime()>.
=head1 FUNCTIONS
=head2 C<timelocal()> and C<timegm()>
-This module exports two functions by default, C<timelocal()> and
-C<timegm()>.
+This module exports two functions by default, C<timelocal()> and C<timegm()>.
-The C<timelocal()> and C<timegm()> functions perform range checking on
-the input $sec, $min, $hour, $mday, and $mon values by default.
+The C<timelocal()> and C<timegm()> functions perform range checking on the
+input $sec, $min, $hour, $mday, and $mon values by default.
=head2 C<timelocal_nocheck()> and C<timegm_nocheck()>
-If you are working with data you know to be valid, you can speed your
-code up by using the "nocheck" variants, C<timelocal_nocheck()> and
+If you are working with data you know to be valid, you can speed your code up
+by using the "nocheck" variants, C<timelocal_nocheck()> and
C<timegm_nocheck()>. These variants must be explicitly imported.
use Time::Local 'timelocal_nocheck';
# The 365th day of 1999
print scalar localtime timelocal_nocheck( 0, 0, 0, 365, 0, 99 );
-If you supply data which is not valid (month 27, second 1,000) the
-results will be unpredictable (so don't do that).
+If you supply data which is not valid (month 27, second 1,000) the results
+will be unpredictable (so don't do that).
=head2 Year Value Interpretation
-Strictly speaking, the year should be specified in a form consistent
-with C<localtime()>, i.e. the offset from 1900. In order to make the
-interpretation of the year easier for humans, however, who are more
-accustomed to seeing years as two-digit or four-digit values, the
-following conventions are followed:
+Strictly speaking, the year should be specified in a form consistent with
+C<localtime()>, i.e. the offset from 1900. In order to make the interpretation
+of the year easier for humans, however, who are more accustomed to seeing
+years as two-digit or four-digit values, the following conventions are
+followed:
=over 4
=item *
-Years greater than 999 are interpreted as being the actual year,
-rather than the offset from 1900. Thus, 1964 would indicate the year
-Martin Luther King won the Nobel prize, not the year 3864.
+Years greater than 999 are interpreted as being the actual year, rather than
+the offset from 1900. Thus, 1964 would indicate the year Martin Luther King
+won the Nobel prize, not the year 3864.
=item *
-Years in the range 100..999 are interpreted as offset from 1900, so
-that 112 indicates 2012. This rule also applies to years less than
-zero (but see note below regarding date range).
+Years in the range 100..999 are interpreted as offset from 1900, so that 112
+indicates 2012. This rule also applies to years less than zero (but see note
+below regarding date range).
=item *
-Years in the range 0..99 are interpreted as shorthand for years in the
-rolling "current century," defined as 50 years on either side of the
-current year. Thus, today, in 1999, 0 would refer to 2000, and 45 to
-2045, but 55 would refer to 1955. Twenty years from now, 55 would
-instead refer to 2055. This is messy, but matches the way people
-currently think about two digit dates. Whenever possible, use an
-absolute four digit year instead.
+Years in the range 0..99 are interpreted as shorthand for years in the rolling
+"current century," defined as 50 years on either side of the current
+year. Thus, today, in 1999, 0 would refer to 2000, and 45 to 2045, but 55
+would refer to 1955. Twenty years from now, 55 would instead refer to
+2055. This is messy, but matches the way people currently think about two
+digit dates. Whenever possible, use an absolute four digit year instead.
=back
-The scheme above allows interpretation of a wide range of dates,
-particularly if 4-digit years are used.
+The scheme above allows interpretation of a wide range of dates, particularly
+if 4-digit years are used.
=head2 Limits of time_t
-On perl versions older than 5.12.0, the range of dates that can be
-actually be handled depends on the size of C<time_t> (usually a signed
-integer) on the given platform. Currently, this is 32 bits for most
-systems, yielding an approximate range from Dec 1901 to Jan 2038.
+On perl versions older than 5.12.0, the range of dates that can be actually be
+handled depends on the size of C<time_t> (usually a signed integer) on the
+given platform. Currently, this is 32 bits for most systems, yielding an
+approximate range from Dec 1901 to Jan 2038.
-Both C<timelocal()> and C<timegm()> croak if given dates outside the
-supported range.
+Both C<timelocal()> and C<timegm()> croak if given dates outside the supported
+range.
-As of version 5.12.0, perl has stopped using the underlying time
-library of the operating system it's running on and has its own
-implementation of those routines with a safe range of at least
-+/ 2**52 (about 142 million years).
+As of version 5.12.0, perl has stopped using the underlying time library of
+the operating system it's running on and has its own implementation of those
+routines with a safe range of at least +/ 2**52 (about 142 million years).
=head2 Ambiguous Local Times (DST)
-Because of DST changes, there are many time zones where the same local
-time occurs for two different GMT times on the same day. For example,
-in the "Europe/Paris" time zone, the local time of 2001-10-28 02:30:00
-can represent either 2001-10-28 00:30:00 GMT, B<or> 2001-10-28
-01:30:00 GMT.
+Because of DST changes, there are many time zones where the same local time
+occurs for two different GMT times on the same day. For example, in the
+"Europe/Paris" time zone, the local time of 2001-10-28 02:30:00 can represent
+either 2001-10-28 00:30:00 GMT, B<or> 2001-10-28 01:30:00 GMT.
-When given an ambiguous local time, the timelocal() function should
-always return the epoch for the I<earlier> of the two possible GMT
-times.
+When given an ambiguous local time, the timelocal() function should always
+return the epoch for the I<earlier> of the two possible GMT times.
=head2 Non-Existent Local Times (DST)
-When a DST change causes a locale clock to skip one hour forward,
-there will be an hour's worth of local times that don't exist. Again,
-for the "Europe/Paris" time zone, the local clock jumped from
-2001-03-25 01:59:59 to 2001-03-25 03:00:00.
+When a DST change causes a locale clock to skip one hour forward, there will
+be an hour's worth of local times that don't exist. Again, for the
+"Europe/Paris" time zone, the local clock jumped from 2001-03-25 01:59:59 to
+2001-03-25 03:00:00.
-If the C<timelocal()> function is given a non-existent local time, it
-will simply return an epoch value for the time one hour later.
+If the C<timelocal()> function is given a non-existent local time, it will
+simply return an epoch value for the time one hour later.
=head2 Negative Epoch Values
-On perl version 5.12.0 and newer, negative epoch values are fully
-supported.
+On perl version 5.12.0 and newer, negative epoch values are fully supported.
-On older versions of perl, negative epoch (C<time_t>) values, which
-are not officially supported by the POSIX standards, are known not to
-work on some systems. These include MacOS (pre-OSX) and Win32.
+On older versions of perl, negative epoch (C<time_t>) values, which are not
+officially supported by the POSIX standards, are known not to work on some
+systems. These include MacOS (pre-OSX) and Win32.
-On systems which do support negative epoch values, this module should
-be able to cope with dates before the start of the epoch, down the
-minimum value of time_t for the system.
+On systems which do support negative epoch values, this module should be able
+to cope with dates before the start of the epoch, down the minimum value of
+time_t for the system.
=head1 IMPLEMENTATION
-These routines are quite efficient and yet are always guaranteed to
-agree with C<localtime()> and C<gmtime()>. We manage this by caching
-the start times of any months we've seen before. If we know the start
-time of the month, we can always calculate any time within the month.
-The start times are calculated using a mathematical formula. Unlike
-other algorithms that do multiple calls to C<gmtime()>.
+These routines are quite efficient and yet are always guaranteed to agree with
+C<localtime()> and C<gmtime()>. We manage this by caching the start times of
+any months we've seen before. If we know the start time of the month, we can
+always calculate any time within the month. The start times are calculated
+using a mathematical formula. Unlike other algorithms that do multiple calls
+to C<gmtime()>.
-The C<timelocal()> function is implemented using the same cache. We
-just assume that we're translating a GMT time, and then fudge it when
-we're done for the timezone and daylight savings arguments. Note that
-the timezone is evaluated for each date because countries occasionally
-change their official timezones. Assuming that C<localtime()> corrects
-for these changes, this routine will also be correct.
+The C<timelocal()> function is implemented using the same cache. We just
+assume that we're translating a GMT time, and then fudge it when we're done
+for the timezone and daylight savings arguments. Note that the timezone is
+evaluated for each date because countries occasionally change their official
+timezones. Assuming that C<localtime()> corrects for these changes, this
+routine will also be correct.
-=head1 BUGS
+=head1 AUTHORS EMERITUS
-The whole scheme for interpreting two-digit years can be considered a
-bug.
+This module is based on a Perl 4 library, timelocal.pl, that was
+included with Perl 4.036, and was most likely written by Tom
+Christiansen.
-=head1 SUPPORT
+The current version was written by Graham Barr.
-Support for this module is provided via the datetime@perl.org email
-list. See http://lists.perl.org/ for more details.
+=head1 BUGS
-Please submit bugs to the CPAN RT system at
-http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Time-Local or via email
-at bug-time-local@rt.cpan.org.
+The whole scheme for interpreting two-digit years can be considered a bug.
-=head1 COPYRIGHT
+Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=Time-Local>
+(or L<bug-time-local@rt.cpan.org|mailto:bug-time-local@rt.cpan.org>).
-Copyright (c) 1997-2003 Graham Barr, 2003-2007 David Rolsky. All
-rights reserved. This program is free software; you can redistribute
-it and/or modify it under the same terms as Perl itself.
+There is a mailing list available for users of this distribution,
+L<mailto:datetime@perl.org>.
-The full text of the license can be found in the LICENSE file included
-with this module.
+I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
-This module is based on a Perl 4 library, timelocal.pl, that was
-included with Perl 4.036, and was most likely written by Tom
-Christiansen.
+Dave Rolsky <autarch@urth.org>
-The current version was written by Graham Barr.
+=head1 CONTRIBUTOR
+
+=for stopwords Florian Ragwitz
+
+Florian Ragwitz <rafl@debian.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 1997 - 2016 by Graham Barr & Dave Rolsky.
-It is now being maintained separately from the Perl core by Dave
-Rolsky, <autarch@urth.org>.
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
=cut
use Time::Local;
# Set up time values to test
-my @time =
- (
- #year,mon,day,hour,min,sec
- [1970, 1, 2, 00, 00, 00],
- [1980, 2, 28, 12, 00, 00],
- [1980, 2, 29, 12, 00, 00],
- [1999, 12, 31, 23, 59, 59],
- [2000, 1, 1, 00, 00, 00],
- [2010, 10, 12, 14, 13, 12],
- # leap day
- [2020, 2, 29, 12, 59, 59],
- [2030, 7, 4, 17, 07, 06],
-
-# The following test fails on a surprising number of systems
-# so it is commented out. The end of the Epoch for a 32-bit signed
-# implementation of time_t should be Jan 19, 2038 03:14:07 UTC.
-# [2038, 1, 17, 23, 59, 59], # last full day in any tz
-
- [2010, 10, 12, 14, 13, 12.1],
- [2010, 10, 12, 14, 13, 59.1],
- );
+my @time = (
+
+ #year,mon,day,hour,min,sec
+ [ 1970, 1, 2, 0, 0, 0 ],
+ [ 1980, 2, 28, 12, 0, 0 ],
+ [ 1980, 2, 29, 12, 0, 0 ],
+ [ 1999, 12, 31, 23, 59, 59 ],
+ [ 2000, 1, 1, 0, 0, 0 ],
+ [ 2010, 10, 12, 14, 13, 12 ],
+
+ # leap day
+ [ 2020, 2, 29, 12, 59, 59 ],
+ [ 2030, 7, 4, 17, 7, 6 ],
+
+ # The following test fails on a surprising number of systems
+ # so it is commented out. The end of the Epoch for a 32-bit signed
+ # implementation of time_t should be Jan 19, 2038 03:14:07 UTC.
+ # [2038, 1, 17, 23, 59, 59], # last full day in any tz
+
+ [ 2010, 10, 12, 14, 13, 12.1 ],
+ [ 2010, 10, 12, 14, 13, 59.1 ],
+);
# more than 2**31 time_t - requires a 64bit safe localtime/gmtime
-push @time, [2258, 8, 11, 1, 49, 17]
+push @time, [ 2258, 8, 11, 1, 49, 17 ]
if $] >= 5.012000;
-my @bad_time =
- (
- # month too large
- [1995, 13, 01, 01, 01, 01],
- # day too large
- [1995, 02, 30, 01, 01, 01],
- # hour too large
- [1995, 02, 10, 25, 01, 01],
- # minute too large
- [1995, 02, 10, 01, 60, 01],
- # second too large
- [1995, 02, 10, 01, 01, 60],
- );
+my @bad_time = (
-my @neg_time =
- (
- # test negative epochs for systems that handle it
- [ 1969, 12, 31, 16, 59, 59 ],
- [ 1950, 04, 12, 9, 30, 31 ],
- );
+ # month too large
+ [ 1995, 13, 1, 1, 1, 1 ],
+
+ # day too large
+ [ 1995, 2, 30, 1, 1, 1 ],
+
+ # hour too large
+ [ 1995, 2, 10, 25, 1, 1 ],
+
+ # minute too large
+ [ 1995, 2, 10, 1, 60, 1 ],
+
+ # second too large
+ [ 1995, 2, 10, 1, 1, 60 ],
+);
+
+my @neg_time = (
+
+ # test negative epochs for systems that handle it
+ [ 1969, 12, 31, 16, 59, 59 ],
+ [ 1950, 4, 12, 9, 30, 31 ],
+);
# Leap year tests
-my @years =
- (
- [ 1900 => 0 ],
- [ 1947 => 0 ],
- [ 1996 => 1 ],
- [ 2000 => 1 ],
- [ 2100 => 0 ],
- );
+my @years = (
+ [ 1900 => 0 ],
+ [ 1947 => 0 ],
+ [ 1996 => 1 ],
+ [ 2000 => 1 ],
+ [ 2100 => 0 ],
+);
# Use 3 days before the start of the epoch because with Borland on
# Win32 it will work for -3600 _if_ your time zone is +01:00 (or
# greater).
-my $neg_epoch_ok = defined ((localtime(-259200))[0]) ? 1 : 0;
+my $neg_epoch_ok = defined( ( localtime(-259200) )[0] ) ? 1 : 0;
# use vmsish 'time' makes for oddness around the Unix epoch
-if ($^O eq 'VMS') {
+if ( $^O eq 'VMS' ) {
$time[0][2]++;
- $neg_epoch_ok = 0; # time_t is unsigned
+ $neg_epoch_ok = 0; # time_t is unsigned
}
-my $epoch_is_64 = eval { $Config{ivsize} == 8 && ( gmtime 2**40 )[5] == 34912 };
+my $epoch_is_64
+ = eval { $Config{ivsize} == 8 && ( gmtime 2**40 )[5] == 34912 };
-for (@time, @neg_time) {
- my($year, $mon, $mday, $hour, $min, $sec) = @$_;
+for ( @time, @neg_time ) {
+ my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
$year -= 1900;
$mon--;
- SKIP: {
+SKIP: {
skip '1970 test on VOS fails.', 12
if $^O eq 'vos' && $year == 70;
skip 'this platform does not support negative epochs.', 12
- if $year < 70 && ! $neg_epoch_ok;
+ if $year < 70 && !$neg_epoch_ok;
# Test timelocal()
{
my $year_in = $year < 70 ? $year + 1900 : $year;
- my $time = timelocal($sec,$min,$hour,$mday,$mon,$year_in);
+ my $time = timelocal( $sec, $min, $hour, $mday, $mon, $year_in );
- my($s,$m,$h,$D,$M,$Y) = localtime($time);
+ my ( $s, $m, $h, $D, $M, $Y ) = localtime($time);
- is($s, int($sec), "timelocal second for @$_");
- is($m, $min, "timelocal minute for @$_");
- is($h, $hour, "timelocal hour for @$_");
- is($D, $mday, "timelocal day for @$_");
- is($M, $mon, "timelocal month for @$_");
- is($Y, $year, "timelocal year for @$_");
+ is( $s, int($sec), "timelocal second for @$_" );
+ is( $m, $min, "timelocal minute for @$_" );
+ is( $h, $hour, "timelocal hour for @$_" );
+ is( $D, $mday, "timelocal day for @$_" );
+ is( $M, $mon, "timelocal month for @$_" );
+ is( $Y, $year, "timelocal year for @$_" );
}
-
# Test timegm()
{
my $year_in = $year < 70 ? $year + 1900 : $year;
- my $time = timegm($sec,$min,$hour,$mday,$mon,$year_in);
+ my $time = timegm( $sec, $min, $hour, $mday, $mon, $year_in );
- my($s,$m,$h,$D,$M,$Y) = gmtime($time);
+ my ( $s, $m, $h, $D, $M, $Y ) = gmtime($time);
- is($s, int($sec), "timegm second for @$_");
- is($m, $min, "timegm minute for @$_");
- is($h, $hour, "timegm hour for @$_");
- is($D, $mday, "timegm day for @$_");
- is($M, $mon, "timegm month for @$_");
- is($Y, $year, "timegm year for @$_");
+ is( $s, int($sec), "timegm second for @$_" );
+ is( $m, $min, "timegm minute for @$_" );
+ is( $h, $hour, "timegm hour for @$_" );
+ is( $D, $mday, "timegm day for @$_" );
+ is( $M, $mon, "timegm month for @$_" );
+ is( $Y, $year, "timegm year for @$_" );
}
}
}
-
for (@bad_time) {
- my($year, $mon, $mday, $hour, $min, $sec) = @$_;
+ my ( $year, $mon, $mday, $hour, $min, $sec ) = @$_;
$year -= 1900;
$mon--;
- eval { timegm($sec,$min,$hour,$mday,$mon,$year) };
+ eval { timegm( $sec, $min, $hour, $mday, $mon, $year ) };
- like($@, qr/.*out of range.*/, 'invalid time caused an error');
+ like( $@, qr/.*out of range.*/, 'invalid time caused an error' );
}
{
- is(timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90), 3600,
- 'one hour difference between two calls to timelocal');
+ is(
+ timelocal( 0, 0, 1, 1, 0, 90 ) - timelocal( 0, 0, 0, 1, 0, 90 ), 3600,
+ 'one hour difference between two calls to timelocal'
+ );
- is(timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99), 24 * 3600,
- 'one day difference between two calls to timelocal');
+ is(
+ timelocal( 1, 2, 3, 1, 0, 100 ) - timelocal( 1, 2, 3, 31, 11, 99 ),
+ 24 * 3600,
+ 'one day difference between two calls to timelocal'
+ );
# Diff beween Jan 1, 1980 and Mar 1, 1980 = (31 + 29 = 60 days)
- is(timegm(0,0,0, 1, 2, 80) - timegm(0,0,0, 1, 0, 80), 60 * 24 * 3600,
- '60 day difference between two calls to timegm');
+ is(
+ timegm( 0, 0, 0, 1, 2, 80 ) - timegm( 0, 0, 0, 1, 0, 80 ),
+ 60 * 24 * 3600,
+ '60 day difference between two calls to timegm'
+ );
}
# bugid #19393
# treated like 03:00:00 rather than 01:00:00 - negative zone offsets used
# to do the latter
{
- my $hour = (localtime(timelocal(0, 0, 2, 7, 3, 102)))[2];
+ my $hour = ( localtime( timelocal( 0, 0, 2, 7, 3, 102 ) ) )[2];
+
# testers in US/Pacific should get 3,
# other testers should get 2
- ok($hour == 2 || $hour == 3, 'hour should be 2 or 3');
+ ok( $hour == 2 || $hour == 3, 'hour should be 2 or 3' );
}
for my $p (@years) {
my ( $year, $is_leap_year ) = @$p;
my $string = $is_leap_year ? 'is' : 'is not';
- is( Time::Local::_is_leap_year($year), $is_leap_year,
- "$year $string a leap year" );
+ ## no critic (Subroutines::ProtectPrivateSubs)
+ is(
+ Time::Local::_is_leap_year($year), $is_leap_year,
+ "$year $string a leap year"
+ );
}
SKIP:
skip 'this platform does not support negative epochs.', 6
unless $neg_epoch_ok;
- eval { timegm(0,0,0,29,1,1900) };
- like($@, qr/Day '29' out of range 1\.\.28/,
- 'does not accept leap day in 1900');
+ eval { timegm( 0, 0, 0, 29, 1, 1900 ) };
+ like(
+ $@, qr/Day '29' out of range 1\.\.28/,
+ 'does not accept leap day in 1900'
+ );
- eval { timegm(0,0,0,29,1,200) };
- like($@, qr/Day '29' out of range 1\.\.28/,
- 'does not accept leap day in 2100 (year passed as 200)');
+ eval { timegm( 0, 0, 0, 29, 1, 200 ) };
+ like(
+ $@, qr/Day '29' out of range 1\.\.28/,
+ 'does not accept leap day in 2100 (year passed as 200)'
+ );
- eval { timegm(0,0,0,29,1,0) };
- is($@, '', 'no error with leap day of 2000 (year passed as 0)');
+ eval { timegm( 0, 0, 0, 29, 1, 0 ) };
+ is( $@, q{}, 'no error with leap day of 2000 (year passed as 0)' );
- eval { timegm(0,0,0,29,1,1904) };
- is($@, '', 'no error with leap day of 1904');
+ eval { timegm( 0, 0, 0, 29, 1, 1904 ) };
+ is( $@, q{}, 'no error with leap day of 1904' );
- eval { timegm(0,0,0,29,1,4) };
- is($@, '', 'no error with leap day of 2004 (year passed as 4)');
+ eval { timegm( 0, 0, 0, 29, 1, 4 ) };
+ is( $@, q{}, 'no error with leap day of 2004 (year passed as 4)' );
- eval { timegm(0,0,0,29,1,96) };
- is($@, '', 'no error with leap day of 1996 (year passed as 96)');
+ eval { timegm( 0, 0, 0, 29, 1, 96 ) };
+ is( $@, q{}, 'no error with leap day of 1996 (year passed as 96)' );
}
SKIP:
skip 'These tests require a system with 64-bit time_t.', 3
unless $epoch_is_64;
- is( timegm( 8, 14, 3, 19, 0, ( 1900 + 138 ) ), 2**31,
- 'can call timegm for 2**31 epoch seconds' );
- is( timegm( 16, 28, 6, 7, 1, ( 1900 + 206 ) ), 2**32,
- 'can call timegm for 2**32 epoch seconds (on a 64-bit system)' );
- is( timegm( 16, 36, 0, 20, 1, ( 34912 + 1900 ) ), 2**40,
- 'can call timegm for 2**40 epoch seconds (on a 64-bit system)' );
+ is(
+ timegm( 8, 14, 3, 19, 0, ( 1900 + 138 ) ), 2**31,
+ 'can call timegm for 2**31 epoch seconds'
+ );
+ is(
+ timegm( 16, 28, 6, 7, 1, ( 1900 + 206 ) ), 2**32,
+ 'can call timegm for 2**32 epoch seconds (on a 64-bit system)'
+ );
+ is(
+ timegm( 16, 36, 0, 20, 1, ( 34912 + 1900 ) ), 2**40,
+ 'can call timegm for 2**40 epoch seconds (on a 64-bit system)'
+ );
}
SKIP:
# 2001-10-28 02:30:00 - could be either summer or standard time,
# prefer earlier of the two, in this case summer
- my $time = timelocal(0, 30, 2, 28, 9, 101);
- is($time, 1004229000,
- 'timelocal prefers earlier epoch in the presence of a DST change');
+ my $time = timelocal( 0, 30, 2, 28, 9, 101 );
+ is(
+ $time, 1004229000,
+ 'timelocal prefers earlier epoch in the presence of a DST change'
+ );
local $ENV{TZ} = 'America/Chicago';
POSIX::tzset();
# Same local time in America/Chicago. There is a transition here
# as well.
- $time = timelocal(0, 30, 1, 28, 9, 101);
- is($time, 1004250600,
- 'timelocal prefers earlier epoch in the presence of a DST change');
+ $time = timelocal( 0, 30, 1, 28, 9, 101 );
+ is(
+ $time, 1004250600,
+ 'timelocal prefers earlier epoch in the presence of a DST change'
+ );
- $time = timelocal(0, 30, 2, 1, 3, 101);
- is($time, 986113800,
- 'timelocal for non-existent time gives you the time one hour later');
+ $time = timelocal( 0, 30, 2, 1, 3, 101 );
+ is(
+ $time, 986113800,
+ 'timelocal for non-existent time gives you the time one hour later'
+ );
local $ENV{TZ} = 'Australia/Sydney';
POSIX::tzset();
+
# 2001-03-25 02:30:00 in Australia/Sydney. This is the transition
# _to_ summer time. The southern hemisphere transitions are
# opposite those of the northern.
- $time = timelocal(0, 30, 2, 25, 2, 101);
- is($time, 985447800,
- 'timelocal prefers earlier epoch in the presence of a DST change');
+ $time = timelocal( 0, 30, 2, 25, 2, 101 );
+ is(
+ $time, 985447800,
+ 'timelocal prefers earlier epoch in the presence of a DST change'
+ );
- $time = timelocal(0, 30, 2, 28, 9, 101);
- is($time, 1004200200,
- 'timelocal for non-existent time gives you the time one hour later');
+ $time = timelocal( 0, 30, 2, 28, 9, 101 );
+ is(
+ $time, 1004200200,
+ 'timelocal for non-existent time gives you the time one hour later'
+ );
local $ENV{TZ} = 'Europe/London';
POSIX::tzset();
$time = timelocal( localtime(1111917720) );
- is($time, 1111917720,
- 'timelocal for round trip bug on date of DST change for Europe/London');
+ is(
+ $time, 1111917720,
+ 'timelocal for round trip bug on date of DST change for Europe/London'
+ );
# There is no 1:00 AM on this date, as it leaps forward to
# 2:00 on the DST change - this should return 2:00 per the
# docs.
- is( ( localtime( timelocal( 0, 0, 1, 27, 2, 2005 ) ) )[2], 2,
- 'hour is 2 when given 1:00 AM on Europe/London date change' );
+ is(
+ ( localtime( timelocal( 0, 0, 1, 27, 2, 2005 ) ) )[2], 2,
+ 'hour is 2 when given 1:00 AM on Europe/London date change'
+ );
- is( ( localtime( timelocal( 0, 0, 2, 27, 2, 2005 ) ) )[2], 2,
- 'hour is 2 when given 2:00 AM on Europe/London date change' );
+ is(
+ ( localtime( timelocal( 0, 0, 2, 27, 2, 2005 ) ) )[2], 2,
+ 'hour is 2 when given 2:00 AM on Europe/London date change'
+ );
}
done_testing();
our @ISA = qw(Exporter Math::BigFloat);
-our $VERSION = '0.43';
+our $VERSION = '0.43_01';
use overload; # inherit overload from BigFloat
our @ISA = qw(Exporter Math::BigInt);
-our $VERSION = '0.43';
+our $VERSION = '0.43_01';
use overload; # inherit overload from BigInt
use strict;
use warnings;
-our $VERSION = '0.43';
+our $VERSION = '0.43_01';
use Exporter;
our @ISA = qw( Exporter );
} else {
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) { # rounding won't work to well
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
if (eval { require Math::BigInt::Lite; 1 }) {
@import = (); # :constant in Lite, not MBI
Math::BigInt::Lite->import(':constant');
use strict;
use warnings;
-our $VERSION = '0.43';
+our $VERSION = '0.43_01';
use Exporter;
our @ISA = qw( bigint );
else {
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) { # rounding won't work to well
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
if (eval { require Math::BigInt::Lite; 1 }) {
@import = (); # :constant in Lite, not MBI
Math::BigInt::Lite->import(':constant');
use strict;
use warnings;
-our $VERSION = '0.43';
+our $VERSION = '0.43_01';
use Exporter;
our @ISA = qw( bigint );
else {
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) { # rounding won't work to well
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
if (eval { require Math::BigInt::Lite; 1 }) {
@import = (); # :constant in Lite, not MBI
Math::BigInt::Lite->import(':constant');
ABSTRACT => 'Collection of network protocol modules',
AUTHOR => 'Graham Barr <gbarr@pobox.com>, Steve Hay <shay@cpan.org>',
LICENSE => 'perl_5',
- VERSION => '3.09',
+ VERSION => '3.10',
META_MERGE => {
'meta-spec' => {
}
}
-our $VERSION = "3.09";
+our $VERSION = "3.10";
our @ISA = qw(Exporter);
our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
1;
}
-sub timeout { 0 }
-
sub _syswrite_with_timeout {
my $cmd = shift;
my $line = shift;
=head1 DESCRIPTION
-C<Net::Cmd> is a collection of methods that can be inherited by a sub class
-of C<IO::Handle>. These methods implement the functionality required for a
+C<Net::Cmd> is a collection of methods that can be inherited by a sub-class
+of C<IO::Socket::INET>. These methods implement the functionality required for a
command based protocol, for example FTP and SMTP.
+If your sub-class does not also derive from C<IO::Socket::INET> or similar (e.g.
+C<IO::Socket::IP>, C<IO::Socket::INET6> or C<IO::Socket::SSL>) then you must
+provide the following methods by other means yourself: C<close()> and
+C<timeout()>.
+
=head1 USER METHODS
These methods provide a user interface to the C<Net::Cmd> object.
Returns undef upon failure.
-=item timeout ()
-
-Returns the timeout value for this class, in seconds. The timeout provided
-by the default implementation is 0; subclasses may override this if they
-choose.
-
=item unsupported ()
Sets the status code to 580 and the response text to 'Unsupported command'.
our @EXPORT = qw(%NetConfig);
our @ISA = qw(Net::LocalCfg Exporter);
-our $VERSION = "3.09";
+our $VERSION = "3.10";
our($CONFIGURE, $LIBNET_CFG);
-eval { local $SIG{__DIE__}; require Net::LocalCfg };
+eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ local $SIG{__DIE__};
+ require Net::LocalCfg;
+};
our %NetConfig = (
nntp_hosts => [],
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
-our $VERSION = "3.09";
+our $VERSION = "3.10";
my ($host, $domain, $fqdn) = (undef, undef, undef);
use Socket;
use Time::Local;
-our $VERSION = '3.09';
+our $VERSION = '3.10';
our $IOCLASS;
my $family_key;
use Net::FTP::dataconn;
our @ISA = qw(Net::FTP::dataconn);
-our $VERSION = "3.09";
+our $VERSION = "3.10";
our $buf;
use Net::FTP::I;
our @ISA = qw(Net::FTP::I);
-our $VERSION = "3.09";
+our $VERSION = "3.10";
1;
use Net::FTP::dataconn;
our @ISA = qw(Net::FTP::dataconn);
-our $VERSION = "3.09";
+our $VERSION = "3.10";
our $buf;
use Net::FTP::I;
our @ISA = qw(Net::FTP::I);
-our $VERSION = "3.09";
+our $VERSION = "3.10";
1;
use Errno;
use Net::Cmd;
-our $VERSION = '3.09';
+our $VERSION = '3.10';
$Net::FTP::IOCLASS or die "please load Net::FTP before Net::FTP::dataconn";
our @ISA = $Net::FTP::IOCLASS;
use Net::Config;
use Time::Local;
-our $VERSION = "3.09";
+our $VERSION = "3.10";
# Code for detecting if we can use SSL
my $ssl_class = eval {
use Carp;
use FileHandle;
-our $VERSION = "3.09";
+our $VERSION = "3.10";
our $TESTING;
use Net::Cmd;
use Net::Config;
-our $VERSION = "3.09";
+our $VERSION = "3.10";
# Code for detecting if we can use SSL
my $ssl_class = eval {
use Net::Config;
use Socket;
-our $VERSION = "3.09";
+our $VERSION = "3.10";
# Code for detecting if we can use SSL
my $ssl_class = eval {
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(inet_time inet_daytime);
-our $VERSION = "3.09";
+our $VERSION = "3.10";
our $TIMEOUT = 120;
use Net::Cmd;
our @ISA = qw(Net::Cmd IO::File);
+ sub timeout { 0 }
+
sub new {
my $fh = shift->new_tmpfile;
binmode($fh);
}
}
-our $VERSION = '1.41';
+our $VERSION = '1.42';
$VERSION =~ tr/_//d;
our $MaxEvalLen = 0;
# cluck, longmess and shortmess not exported by default
use Carp qw(cluck longmess shortmess);
- cluck "This is how we got here!";
+ cluck "This is how we got here!"; # warn with stack backtrace
$long_message = longmess( "message from cluck() or confess()" );
$short_message = shortmess( "message from carp() or croak()" );
use Carp ();
-our $VERSION = '1.41';
+our $VERSION = '1.42';
$VERSION =~ tr/_//d;
# Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions
#!perl
use 5.006;
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
eval {
require ExtUtils::ParseXS;
);
%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
-$VERSION = "0.40";
+$VERSION = "0.41";
sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function
BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
# define the constant 'DEBUG' at compile-time
-$VERSION = "1.05";
+$VERSION = "1.06";
@ISA = ();
use I18N::LangTags qw(alternate_language_tags locale2language_tag);
print " About to use $module ...\n" if DEBUG;
{
local $SIG{'__DIE__'};
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
eval "require $module"; # used to be "use $module", but no point in that.
}
if($@) {
use strict;
use warnings;
-our $VERSION = "1.36";
+our $VERSION = "1.37";
XSLoader::load 'IO', $VERSION;
sub import {
my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir);
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l)
or croak $@;
}
Revision history for Perl suite Locale::Maketext
+2016-07-25
+ * Release of 1.28 to CPAN
+ * Fix optional runtime load for CVE-2016-1238
+
2016-06-22
* Release of 1.27 to CPAN
}
-$VERSION = '1.27';
+$VERSION = '1.28';
@ISA = ();
$MATCH_SUPERS = 1;
local $SIG{'__DIE__'};
local $@;
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
eval "require $module"; # used to be "use $module", but no point in that.
if($@) {
+5.20160820
+ - Updated for v5.25.4
+
5.20160720
- Updated for v5.25.3
=cut
+BEGIN { pop @INC if $INC[-1] eq '.' }
use Module::CoreList;
use Getopt::Long qw(:config no_ignore_case);
use Pod::Usage;
use vars qw/$VERSION %released %version %families %upstream
%bug_tracker %deprecated %delta/;
use version;
-$VERSION = '5.20160720';
+$VERSION = '5.20160820';
sub _undelta {
my ($delta) = @_;
5.025001 => '2016-05-20',
5.025002 => '2016-06-20',
5.025003 => '2016-07-20',
+ 5.025004 => '2016-08-20',
);
for my $version ( sort { $a <=> $b } keys %released ) {
removed => {
}
},
+ 5.025004 => {
+ delta_from => 5.025003,
+ changed => {
+ 'App::Cpan' => '1.64_01',
+ 'App::Prove' => '3.36_01',
+ 'App::Prove::State' => '3.36_01',
+ 'App::Prove::State::Result'=> '3.36_01',
+ 'App::Prove::State::Result::Test'=> '3.36_01',
+ 'Archive::Tar' => '2.10',
+ 'Archive::Tar::Constant'=> '2.10',
+ 'Archive::Tar::File' => '2.10',
+ 'B' => '1.63',
+ 'B::Concise' => '0.998',
+ 'B::Deparse' => '1.38',
+ 'B::Op_private' => '5.025004',
+ 'CPAN' => '2.14_01',
+ 'CPAN::Meta' => '2.150010',
+ 'CPAN::Meta::Converter' => '2.150010',
+ 'CPAN::Meta::Feature' => '2.150010',
+ 'CPAN::Meta::History' => '2.150010',
+ 'CPAN::Meta::Merge' => '2.150010',
+ 'CPAN::Meta::Prereqs' => '2.150010',
+ 'CPAN::Meta::Spec' => '2.150010',
+ 'CPAN::Meta::Validator' => '2.150010',
+ 'Carp' => '1.42',
+ 'Carp::Heavy' => '1.42',
+ 'Compress::Zlib' => '2.069_01',
+ 'Config' => '5.025004',
+ 'Config::Perl::V' => '0.27',
+ 'Cwd' => '3.65',
+ 'Digest' => '1.17_01',
+ 'Digest::SHA' => '5.96',
+ 'Encode' => '2.86',
+ 'Errno' => '1.26',
+ 'ExtUtils::Command' => '7.24',
+ 'ExtUtils::Command::MM' => '7.24',
+ 'ExtUtils::Liblist' => '7.24',
+ 'ExtUtils::Liblist::Kid'=> '7.24',
+ 'ExtUtils::MM' => '7.24',
+ 'ExtUtils::MM_AIX' => '7.24',
+ 'ExtUtils::MM_Any' => '7.24',
+ 'ExtUtils::MM_BeOS' => '7.24',
+ 'ExtUtils::MM_Cygwin' => '7.24',
+ 'ExtUtils::MM_DOS' => '7.24',
+ 'ExtUtils::MM_Darwin' => '7.24',
+ 'ExtUtils::MM_MacOS' => '7.24',
+ 'ExtUtils::MM_NW5' => '7.24',
+ 'ExtUtils::MM_OS2' => '7.24',
+ 'ExtUtils::MM_QNX' => '7.24',
+ 'ExtUtils::MM_UWIN' => '7.24',
+ 'ExtUtils::MM_Unix' => '7.24',
+ 'ExtUtils::MM_VMS' => '7.24',
+ 'ExtUtils::MM_VOS' => '7.24',
+ 'ExtUtils::MM_Win32' => '7.24',
+ 'ExtUtils::MM_Win95' => '7.24',
+ 'ExtUtils::MY' => '7.24',
+ 'ExtUtils::MakeMaker' => '7.24',
+ 'ExtUtils::MakeMaker::Config'=> '7.24',
+ 'ExtUtils::MakeMaker::Locale'=> '7.24',
+ 'ExtUtils::MakeMaker::version'=> '7.24',
+ 'ExtUtils::MakeMaker::version::regex'=> '7.24',
+ 'ExtUtils::Mkbootstrap' => '7.24',
+ 'ExtUtils::Mksymlists' => '7.24',
+ 'ExtUtils::testlib' => '7.24',
+ 'File::Fetch' => '0.52',
+ 'File::Spec' => '3.65',
+ 'File::Spec::AmigaOS' => '3.65',
+ 'File::Spec::Cygwin' => '3.65',
+ 'File::Spec::Epoc' => '3.65',
+ 'File::Spec::Functions' => '3.65',
+ 'File::Spec::Mac' => '3.65',
+ 'File::Spec::OS2' => '3.65',
+ 'File::Spec::Unix' => '3.65',
+ 'File::Spec::VMS' => '3.65',
+ 'File::Spec::Win32' => '3.65',
+ 'HTTP::Tiny' => '0.064',
+ 'Hash::Util' => '0.21',
+ 'I18N::LangTags' => '0.41',
+ 'I18N::LangTags::Detect'=> '1.06',
+ 'IO' => '1.37',
+ 'IO::Compress::Adapter::Bzip2'=> '2.069_01',
+ 'IO::Compress::Adapter::Deflate'=> '2.069_01',
+ 'IO::Compress::Adapter::Identity'=> '2.069_01',
+ 'IO::Compress::Base' => '2.069_01',
+ 'IO::Compress::Base::Common'=> '2.069_01',
+ 'IO::Compress::Bzip2' => '2.069_01',
+ 'IO::Compress::Deflate' => '2.069_01',
+ 'IO::Compress::Gzip' => '2.069_01',
+ 'IO::Compress::Gzip::Constants'=> '2.069_01',
+ 'IO::Compress::RawDeflate'=> '2.069_01',
+ 'IO::Compress::Zip' => '2.069_01',
+ 'IO::Compress::Zip::Constants'=> '2.069_01',
+ 'IO::Compress::Zlib::Constants'=> '2.069_01',
+ 'IO::Compress::Zlib::Extra'=> '2.069_01',
+ 'IO::Socket::IP' => '0.38',
+ 'IO::Uncompress::Adapter::Bunzip2'=> '2.069_01',
+ 'IO::Uncompress::Adapter::Identity'=> '2.069_01',
+ 'IO::Uncompress::Adapter::Inflate'=> '2.069_01',
+ 'IO::Uncompress::AnyInflate'=> '2.069_01',
+ 'IO::Uncompress::AnyUncompress'=> '2.069_01',
+ 'IO::Uncompress::Base' => '2.069_01',
+ 'IO::Uncompress::Bunzip2'=> '2.069_01',
+ 'IO::Uncompress::Gunzip'=> '2.069_01',
+ 'IO::Uncompress::Inflate'=> '2.069_01',
+ 'IO::Uncompress::RawInflate'=> '2.069_01',
+ 'IO::Uncompress::Unzip' => '2.069_01',
+ 'IPC::Cmd' => '0.96',
+ 'JSON::PP' => '2.27400_01',
+ 'Locale::Maketext' => '1.28',
+ 'Locale::Maketext::Simple'=> '0.21_01',
+ 'Math::BigFloat::Trace' => '0.43_01',
+ 'Math::BigInt::Trace' => '0.43_01',
+ 'Memoize' => '1.03_01',
+ 'Module::CoreList' => '5.20160820',
+ 'Module::CoreList::TieHashDelta'=> '5.20160820',
+ 'Module::CoreList::Utils'=> '5.20160820',
+ 'Module::Load::Conditional'=> '0.68',
+ 'Module::Metadata' => '1.000033',
+ 'NEXT' => '0.67',
+ 'Net::Cmd' => '3.10',
+ 'Net::Config' => '3.10',
+ 'Net::Domain' => '3.10',
+ 'Net::FTP' => '3.10',
+ 'Net::FTP::A' => '3.10',
+ 'Net::FTP::E' => '3.10',
+ 'Net::FTP::I' => '3.10',
+ 'Net::FTP::L' => '3.10',
+ 'Net::FTP::dataconn' => '3.10',
+ 'Net::NNTP' => '3.10',
+ 'Net::Netrc' => '3.10',
+ 'Net::POP3' => '3.10',
+ 'Net::Ping' => '2.44',
+ 'Net::SMTP' => '3.10',
+ 'Net::Time' => '3.10',
+ 'Opcode' => '1.37',
+ 'POSIX' => '1.71',
+ 'Parse::CPAN::Meta' => '2.150010',
+ 'Pod::Html' => '1.2201',
+ 'Pod::Perldoc' => '3.27',
+ 'Pod::Perldoc::BaseTo' => '3.27',
+ 'Pod::Perldoc::GetOptsOO'=> '3.27',
+ 'Pod::Perldoc::ToANSI' => '3.27',
+ 'Pod::Perldoc::ToChecker'=> '3.27',
+ 'Pod::Perldoc::ToMan' => '3.27',
+ 'Pod::Perldoc::ToNroff' => '3.27',
+ 'Pod::Perldoc::ToPod' => '3.27',
+ 'Pod::Perldoc::ToRtf' => '3.27',
+ 'Pod::Perldoc::ToTerm' => '3.27',
+ 'Pod::Perldoc::ToText' => '3.27',
+ 'Pod::Perldoc::ToTk' => '3.27',
+ 'Pod::Perldoc::ToXml' => '3.27',
+ 'Storable' => '2.57',
+ 'Sys::Syslog' => '0.34_01',
+ 'TAP::Base' => '3.36_01',
+ 'TAP::Formatter::Base' => '3.36_01',
+ 'TAP::Formatter::Color' => '3.36_01',
+ 'TAP::Formatter::Console'=> '3.36_01',
+ 'TAP::Formatter::Console::ParallelSession'=> '3.36_01',
+ 'TAP::Formatter::Console::Session'=> '3.36_01',
+ 'TAP::Formatter::File' => '3.36_01',
+ 'TAP::Formatter::File::Session'=> '3.36_01',
+ 'TAP::Formatter::Session'=> '3.36_01',
+ 'TAP::Harness' => '3.36_01',
+ 'TAP::Harness::Env' => '3.36_01',
+ 'TAP::Object' => '3.36_01',
+ 'TAP::Parser' => '3.36_01',
+ 'TAP::Parser::Aggregator'=> '3.36_01',
+ 'TAP::Parser::Grammar' => '3.36_01',
+ 'TAP::Parser::Iterator' => '3.36_01',
+ 'TAP::Parser::Iterator::Array'=> '3.36_01',
+ 'TAP::Parser::Iterator::Process'=> '3.36_01',
+ 'TAP::Parser::Iterator::Stream'=> '3.36_01',
+ 'TAP::Parser::IteratorFactory'=> '3.36_01',
+ 'TAP::Parser::Multiplexer'=> '3.36_01',
+ 'TAP::Parser::Result' => '3.36_01',
+ 'TAP::Parser::Result::Bailout'=> '3.36_01',
+ 'TAP::Parser::Result::Comment'=> '3.36_01',
+ 'TAP::Parser::Result::Plan'=> '3.36_01',
+ 'TAP::Parser::Result::Pragma'=> '3.36_01',
+ 'TAP::Parser::Result::Test'=> '3.36_01',
+ 'TAP::Parser::Result::Unknown'=> '3.36_01',
+ 'TAP::Parser::Result::Version'=> '3.36_01',
+ 'TAP::Parser::Result::YAML'=> '3.36_01',
+ 'TAP::Parser::ResultFactory'=> '3.36_01',
+ 'TAP::Parser::Scheduler'=> '3.36_01',
+ 'TAP::Parser::Scheduler::Job'=> '3.36_01',
+ 'TAP::Parser::Scheduler::Spinner'=> '3.36_01',
+ 'TAP::Parser::Source' => '3.36_01',
+ 'TAP::Parser::SourceHandler'=> '3.36_01',
+ 'TAP::Parser::SourceHandler::Executable'=> '3.36_01',
+ 'TAP::Parser::SourceHandler::File'=> '3.36_01',
+ 'TAP::Parser::SourceHandler::Handle'=> '3.36_01',
+ 'TAP::Parser::SourceHandler::Perl'=> '3.36_01',
+ 'TAP::Parser::SourceHandler::RawTAP'=> '3.36_01',
+ 'TAP::Parser::YAMLish::Reader'=> '3.36_01',
+ 'TAP::Parser::YAMLish::Writer'=> '3.36_01',
+ 'Test' => '1.29',
+ 'Test2' => '1.302052',
+ 'Test2::API' => '1.302052',
+ 'Test2::API::Breakage' => '1.302052',
+ 'Test2::API::Context' => '1.302052',
+ 'Test2::API::Instance' => '1.302052',
+ 'Test2::API::Stack' => '1.302052',
+ 'Test2::Event' => '1.302052',
+ 'Test2::Event::Bail' => '1.302052',
+ 'Test2::Event::Diag' => '1.302052',
+ 'Test2::Event::Exception'=> '1.302052',
+ 'Test2::Event::Generic' => '1.302052',
+ 'Test2::Event::Info' => '1.302052',
+ 'Test2::Event::Note' => '1.302052',
+ 'Test2::Event::Ok' => '1.302052',
+ 'Test2::Event::Plan' => '1.302052',
+ 'Test2::Event::Skip' => '1.302052',
+ 'Test2::Event::Subtest' => '1.302052',
+ 'Test2::Event::Waiting' => '1.302052',
+ 'Test2::Formatter' => '1.302052',
+ 'Test2::Formatter::TAP' => '1.302052',
+ 'Test2::Hub' => '1.302052',
+ 'Test2::Hub::Interceptor'=> '1.302052',
+ 'Test2::Hub::Interceptor::Terminator'=> '1.302052',
+ 'Test2::Hub::Subtest' => '1.302052',
+ 'Test2::IPC' => '1.302052',
+ 'Test2::IPC::Driver' => '1.302052',
+ 'Test2::IPC::Driver::Files'=> '1.302052',
+ 'Test2::Util' => '1.302052',
+ 'Test2::Util::ExternalMeta'=> '1.302052',
+ 'Test2::Util::HashBase' => '1.302052',
+ 'Test2::Util::Trace' => '1.302052',
+ 'Test::Builder' => '1.302052',
+ 'Test::Builder::Formatter'=> '1.302052',
+ 'Test::Builder::Module' => '1.302052',
+ 'Test::Builder::Tester' => '1.302052',
+ 'Test::Builder::Tester::Color'=> '1.302052',
+ 'Test::Builder::TodoDiag'=> '1.302052',
+ 'Test::Harness' => '3.36_01',
+ 'Test::More' => '1.302052',
+ 'Test::Simple' => '1.302052',
+ 'Test::Tester' => '1.302052',
+ 'Test::Tester::Capture' => '1.302052',
+ 'Test::Tester::CaptureRunner'=> '1.302052',
+ 'Test::Tester::Delegate'=> '1.302052',
+ 'Test::use::ok' => '1.302052',
+ 'Tie::Hash::NamedCapture'=> '0.10',
+ 'Time::Local' => '1.24',
+ 'XS::APItest' => '0.83',
+ 'arybase' => '0.12',
+ 'base' => '2.24',
+ 'bigint' => '0.43_01',
+ 'bignum' => '0.43_01',
+ 'bigrat' => '0.43_01',
+ 'encoding' => '2.18',
+ 'ok' => '1.302052',
+ },
+ removed => {
+ }
+ },
);
sub is_core
removed => {
}
},
+ 5.025004 => {
+ delta_from => 5.025003,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
%deprecated = _undelta(\%deprecated);
'Net::SMTP' => undef,
'Net::Time' => undef,
'Params::Check' => undef,
- 'Parse::CPAN::Meta' => 'https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta/issues',
+ 'Parse::CPAN::Meta' => 'https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues',
'Perl::OSType' => 'https://github.com/Perl-Toolchain-Gang/Perl-OSType/issues',
'PerlIO::via::QuotedPrint'=> undef,
'Pod::Checker' => undef,
'Text::Tabs' => undef,
'Text::Wrap' => undef,
'Tie::RefHash' => undef,
- 'Time::Local' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Time-Local',
+ 'Time::Local' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Time-Local',
'Time::Piece' => undef,
'Time::Seconds' => undef,
'Unicode::Collate' => undef,
use strict;
use vars qw($VERSION);
-$VERSION = '5.20160720';
+$VERSION = '5.20160820';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
use vars qw[$VERSION %utilities];
use Module::CoreList;
-$VERSION = '5.20160720';
+$VERSION = '5.20160820';
sub utilities {
my $perl = shift;
removed => {
}
},
+ 5.025004 => {
+ delta_from => 5.025003,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
%utilities = Module::CoreList::_undelta(\%delta);
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.43";
+$VERSION = "2.44";
# Constants
$timeout # Seconds after which ping times out
) = @_;
- eval { require Net::Ping::External; }
+ eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require Net::Ping::External;
+ }
or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
}
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.64';
+$VERSION = '3.65';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;
my $use_vms_feature;
BEGIN {
if ($^O eq 'VMS') {
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ if (eval { local $SIG{__DIE__};
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require VMS::Feature; }) {
$use_vms_feature = 1;
}
}
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
my %module = (MacOS => 'Mac',
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
if ($mntopts and ($mntopts =~ /,managed/)) {
return 0;
}
- eval { require Win32API::File; } or return 1;
+ eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require Win32API::File;
+ } or return 1;
my $osFsType = "\0"x256;
my $osVolName = "\0"x256;
my $ouFsFlags = 0;
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
require File::Spec::Unix;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
require Exporter;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION);
-$VERSION = '3.64';
+$VERSION = '3.65';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
my $use_feature;
BEGIN {
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ if (eval { local $SIG{__DIE__};
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require VMS::Feature; }) {
$use_feature = 1;
}
}
# [-.-. ==> [--.
# .-.-] ==> .--]
# [-.-] ==> [--]
- 1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
+ 1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/);
# That loop does the following
# with any amount (minimum 2)
# of dashes:
#
# And then, the remaining cases
$path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [-
- $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
- $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
- $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
+ $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g; # .foo.-. ==> .
+ $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g; # [foo.-. ==> [
+ $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g; # .foo.-] ==> ]
# [foo.-] ==> [000000]
- $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g;
+ $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g;
# [] ==>
$path =~ s/(?<!\^)\[\]// unless $path eq '[]';
return $unix_rpt ? unixify($path) : $path;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.64';
+$VERSION = '3.65';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
=cut
sub case_tolerant {
- eval { require Win32API::File; } or return 1;
+ eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require Win32API::File;
+ } or return 1;
my $drive = shift || "C:";
my $osFsType = "\0"x256;
my $osVolName = "\0"x256;
# During the Perl 5.8 era, FS::Unix stopped eliminating redundant path elements, so mimic that here.
[ "VMS->canonpath('a/../../b/c.dat')", $vms_unix_rpt ? 'a/../../b/c.dat' : '[-.b]c.dat' ],
[ "VMS->canonpath('^<test^.new.-.caret^ escapes^>')", $vms_unix_rpt ? '/<test.new.-.caret escapes>' : '^<test^.new.-.caret^ escapes^>' ],
+# Check that directory specs with caret-dot component is treated correctly
+[ "VMS->canonpath('foo:[bar.coo.kie.--]file.txt')", $vms_unix_rpt ? '/foo/bar/file.txt' : "foo:[bar]file.txt" ],
+[ "VMS->canonpath('foo:[bar^.coo.kie.--]file.txt')", $vms_unix_rpt ? '/foo/file.txt' : "foo:[000000]file.txt" ],
+[ "VMS->canonpath('foo:[bar.coo^.kie.--]file.txt')", $vms_unix_rpt ? '/foo/file.txt' : "foo:[000000]file.txt" ],
+[ "VMS->canonpath('foo:[bar.coo.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar/coo/file.txt' : "foo:[bar.coo]file.txt" ],
+[ "VMS->canonpath('foo:[bar^.coo.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar.coo/file.txt' : "foo:[bar^.coo]file.txt" ],
+[ "VMS->canonpath('foo:[bar.coo^.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar/file.txt' : "foo:[bar]file.txt" ],
[ "VMS->splitdir('')", '' ],
[ "VMS->splitdir('[]')", '' ],
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.56';
+$VERSION = '2.57';
BEGIN {
- if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) {
+ if (eval {
+ local $SIG{__DIE__};
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require Log::Agent;
+ 1;
+ }) {
Log::Agent->import;
}
#
$$cloned{a} = "blah";
is($$cloned{''}[0], \$$cloned{a});
-# [ID 20020221.007] SEGV in Storable with empty string scalar object
+# [ID 20020221.007 (#8624)] SEGV in Storable with empty string scalar object
package TestString;
sub new {
my ($type, $string) = @_;
#
# Is the reference count of the extra references returned from a
-# STORABLE_freeze hook correct? [ID 20020601.005]
+# STORABLE_freeze hook correct? [ID 20020601.005 (#9436)]
#
package Foo2;
$planned = 0;
}
-$VERSION = '1.28';
+$VERSION = '1.29';
require Exporter;
@ISA=('Exporter');
my($result, $expected, $detail, $prefix) = @_;
return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF};
return _diff_complain_algdiff(@_)
- if eval { require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); 1; };
+ if eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require Algorithm::Diff; Algorithm::Diff->VERSION(1.15);
+ 1;
+ };
$told_about_diff++ or print $TESTERR <<"EOT";
# $prefix (Install the Algorithm::Diff module to have differences in multiline
PL_FILES => { 'XSLoader_pm.PL' => 'XSLoader.pm' },
PM => { 'XSLoader.pm' => '$(INST_ARCHLIB)/XSLoader.pm' },
PREREQ_PM => {
+ # NOTE: If we should require a Test::More version higher than 0.98
+ # (that included with perl 5.14), we need to remove the meta-spec
+ # entry below for EUMM 6.57_02 to 6.57_06 (the buggy versions
+ # included with perl 5.14). Otherwise installation will break.
+ # See https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues/118
+ # for details.
'Test::More' => '0.47',
},
META_MERGE => {
- resources => {
- repository => 'git://perl5.git.perl.org/perl.git',
- license => 'http://dev.perl.org/licenses/',
+ 'meta-spec' => { version => 2 },
+ dynamic_config => 0,
+ resources => {
+ repository => {
+ type => 'git',
+ url => 'git://perl5.git.perl.org/perl.git',
+ },
homepage => 'https://metacpan.org/module/XSLoader',
- irc => 'irc://irc.perl.org/#p5p',
- mailinglist => 'http://lists.perl.org/list/perl5-porters.html',
- bugtracker => "https://rt.perl.org/rt3/Search/Results.html?Query=Queue='perl5' AND Content LIKE 'module=XSLoader' AND (Status='open' OR Status='new' OR Status='stalled')",
+ x_IRC => 'irc://irc.perl.org/#p5p',
+ x_MailingList => 'http://lists.perl.org/list/perl5-porters.html',
+ bugtracker => {
+ mailto => 'perlbug@perl.org',
+ web => "https://rt.perl.org/rt3/Search/Results.html?Query=Queue='perl5' AND Content LIKE 'module=XSLoader' AND (Status='open' OR Status='new' OR Status='stalled')",
+ },
+ },
+ provides => {
+ 'XSLoader' => {
+ file => 'XSLoader_pm.PL',
+ version => ${$PACKAGE.'::VERSION'},
+ },
},
},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
pseudohashes
* Fixing inheritance from classes which have only private fields
* Fixing inheritance when an intermediate class has no fields.
- [perlbug 20020326.004]
+ [perlbug 20020326.004 (#8884)]
- Removing uses of 'our' from tests for backwards compat.
2.02 Wed Sep 3 20:40:13 PDT 2003
use strict 'vars';
use vars qw($VERSION);
-$VERSION = '2.23';
+$VERSION = '2.24';
$VERSION =~ tr/_//d;
# constant.pm is slow
{
local $SIG{__DIE__};
my $fn = _module_to_filename($base);
- eval { require $fn };
+ local @INC = @INC;
+ pop @INC if my $dotty = $INC[-1] eq '.';
+ eval {
+ require $fn
+ };
# Only ignore "Can't locate" errors from our eval require.
# Other fatal errors (syntax etc) must be reported.
#
unless (%{"$base\::"}) {
require Carp;
local $" = " ";
- Carp::croak(<<ERROR);
+ my $e = <<ERROR;
Base class package "$base" is empty.
(Perhaps you need to 'use' the module which defines that package first,
or make that module available in \@INC (\@INC contains: @INC).
ERROR
+ if ($dotty && -e $fn) {
+ $e .= <<ERROS;
+ The file $fn does exist in the current directory. But note
+ that base.pm, when loading a module, now ignores the current working
+ directory if it is the last entry in \@INC. If your software worked on
+ previous versions of Perl, the best solution is to use FindBin to
+ detect the path properly and to add that path to \@INC. As a last
+ resort, you can re-enable looking in the current working directory by
+ adding "use lib '.'" to your code.
+ERROS
+ }
+ $e =~ s/\n\z/)\n/;
+ Carp::croak($e);
}
$sigdie = $SIG{__DIE__} || undef;
}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+
+use base ();
+
+use Test::More tests => 2;
+
+if ($INC[-1] ne '.') { push @INC, '.' }
+
+my $inc = quotemeta "@INC[0..$#INC-1]";
+
+eval { 'base'->import("foo") };
+like $@, qr/\@INC contains: $inc\).\)/,
+ 'Error does not list final dot in @INC (or mention use lib)';
+eval { 'base'->import('t::lib::Dummy') };
+like $@, qr<\@INC contains: $inc\).\n(?x:
+ ) The file t/lib/Dummy\.pm does exist in the current direct>,
+ 'special cur dir message for existing files in . that are ignored';
int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
APPLY_TAINT_PROPER();
if (fd < 0) {
- SETERRNO(EBADF,RMS_IFI);
- tot--;
-#if Uid_t_sign == 1
- } else if (val < 0) {
- SETERRNO(EINVAL,LIB_INVARG);
- tot--;
-#endif
-#if Gid_t_sign == 1
- } else if (val2 < 0) {
- SETERRNO(EINVAL,LIB_INVARG);
+ SETERRNO(EBADF,RMS_IFI);
tot--;
-#endif
} else if (fchown(fd, val, val2))
tot--;
#else
#endif /* !CSH */
#endif /* !DOSISH */
{
- GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
- SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
- SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
- if (home && *home) SvGETMAGIC(*home);
- if (path && *path) SvGETMAGIC(*path);
- save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
- if (home && *home) SvSETMAGIC(*home);
- if (path && *path) SvSETMAGIC(*path);
+ SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
+ if (svp && *svp)
+ save_helem_flags(GvHV(PL_envgv),
+ newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
+ SAVEf_SETMAGIC);
}
(void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
NULL, NULL, 0);
if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
SvCUR(d) ? SvPVX_const(d) + 1 : "");
- if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
+ if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
SSize_t count;
- for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
- SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
-
+ SV **svp = AvARRAY(MUTABLE_AV(sv));
+ for (count = 0;
+ count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
+ count++, svp++)
+ {
+ SV* const elt = *svp;
Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
- if (elt)
- do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
+ do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
}
}
break;
case OP_PADSV:
case OP_PADAV:
case OP_PADHV:
+ case OP_ARGELEM:
S_deb_padvar(aTHX_ o->op_targ, 1, 1);
break;
: If the function is only exported for use in a public
: macro, see X.
:
-: a Allocates memory a la malloc/calloc. Also implies "R":
+: a Allocates memory a la malloc/calloc. Also implies "R".
+: This should only be on functions which returns 'empty' memory
+: which has no other pointers to it, and which does not contain
+: any pointers to other things. So for example realloc() can't be
+: 'a'.
:
: proto.h: add __attribute__malloc__
:
Aanop |Malloc_t|malloc |MEM_SIZE nbytes
Aanop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size
-Aanop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes
+ARnop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes
Anop |Free_t |mfree |Malloc_t where
#if defined(MYMALLOC)
npR |MEM_SIZE|malloced_size |NN void *p
|NN const char *const params
npr |void |croak_no_mem
nprX |void |croak_popstack
+fnrp |void |croak_caller|NULLOK const char* pat|...
fnprx |void |noperl_die|NN const char* pat|...
#if defined(WIN32)
norx |void |win32_croak_not_implemented|NN const char * fname
ApdR |char* |fbm_instr |NN unsigned char* big|NN unsigned char* bigend \
|NN SV* littlestr|U32 flags
p |CV * |find_lexical_cv|PADOFFSET off
-pR |OP * |parse_subsignature
: Defined in util.c, used only in perl.c
p |char* |find_script |NN const char *scriptname|bool dosearch \
|NULLOK const char *const *const search_ext|I32 flags
p |void |my_unexec
AbDMnPR |UV |NATIVE_TO_NEED |const UV enc|const UV ch
AbDMnPR |UV |ASCII_TO_NEED |const UV enc|const UV ch
-Apa |OP* |newANONLIST |NULLOK OP* o
-Apa |OP* |newANONHASH |NULLOK OP* o
+ApR |OP* |newANONLIST |NULLOK OP* o
+ApR |OP* |newANONHASH |NULLOK OP* o
Ap |OP* |newANONSUB |I32 floor|NULLOK OP* proto|NULLOK OP* block
-Apda |OP* |newASSIGNOP |I32 flags|NULLOK OP* left|I32 optype|NULLOK OP* right
-Apda |OP* |newCONDOP |I32 flags|NN OP* first|NULLOK OP* trueop|NULLOK OP* falseop
+ApdR |OP* |newASSIGNOP |I32 flags|NULLOK OP* left|I32 optype|NULLOK OP* right
+ApdR |OP* |newCONDOP |I32 flags|NN OP* first|NULLOK OP* trueop|NULLOK OP* falseop
Apd |CV* |newCONSTSUB |NULLOK HV* stash|NULLOK const char* name|NULLOK SV* sv
Apd |CV* |newCONSTSUB_flags|NULLOK HV* stash \
|NULLOK const char* name|STRLEN len \
|U32 flags|NULLOK SV* sv
Ap |void |newFORM |I32 floor|NULLOK OP* o|NULLOK OP* block
-Apda |OP* |newFOROP |I32 flags|NULLOK OP* sv|NN OP* expr|NULLOK OP* block|NULLOK OP* cont
-Apda |OP* |newGIVENOP |NN OP* cond|NN OP* block|PADOFFSET defsv_off
-Apda |OP* |newLOGOP |I32 optype|I32 flags|NN OP *first|NN OP *other
-Apda |OP* |newLOOPEX |I32 type|NN OP* label
-Apda |OP* |newLOOPOP |I32 flags|I32 debuggable|NULLOK OP* expr|NULLOK OP* block
-Apda |OP* |newNULLLIST
-Apda |OP* |newOP |I32 optype|I32 flags
+ApdR |OP* |newFOROP |I32 flags|NULLOK OP* sv|NN OP* expr|NULLOK OP* block|NULLOK OP* cont
+ApdR |OP* |newGIVENOP |NN OP* cond|NN OP* block|PADOFFSET defsv_off
+ApdR |OP* |newLOGOP |I32 optype|I32 flags|NN OP *first|NN OP *other
+pM |LOGOP* |alloc_LOGOP |I32 type|NULLOK OP *first|NULLOK OP *other
+ApdR |OP* |newLOOPEX |I32 type|NN OP* label
+ApdR |OP* |newLOOPOP |I32 flags|I32 debuggable|NULLOK OP* expr|NULLOK OP* block
+ApdR |OP* |newNULLLIST
+ApdR |OP* |newOP |I32 optype|I32 flags
Ap |void |newPROG |NN OP* o
-Apda |OP* |newRANGE |I32 flags|NN OP* left|NN OP* right
-Apda |OP* |newSLICEOP |I32 flags|NULLOK OP* subscript|NULLOK OP* listop
-Apda |OP* |newSTATEOP |I32 flags|NULLOK char* label|NULLOK OP* o
+ApdR |OP* |newRANGE |I32 flags|NN OP* left|NN OP* right
+ApdR |OP* |newSLICEOP |I32 flags|NULLOK OP* subscript|NULLOK OP* listop
+ApdR |OP* |newSTATEOP |I32 flags|NULLOK char* label|NULLOK OP* o
Apbm |CV* |newSUB |I32 floor|NULLOK OP* o|NULLOK OP* proto \
|NULLOK OP* block
p |CV * |newXS_len_flags|NULLOK const char *name|STRLEN len \
Apd |CV* |newXS |NULLOK const char *name|NN XSUBADDR_t subaddr\
|NN const char *filename
ApmdbR |AV* |newAV
-Apa |OP* |newAVREF |NN OP* o
-Apda |OP* |newBINOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last
-Apa |OP* |newCVREF |I32 flags|NULLOK OP* o
-Apda |OP* |newGVOP |I32 type|I32 flags|NN GV* gv
+ApR |OP* |newAVREF |NN OP* o
+ApdR |OP* |newBINOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last
+ApR |OP* |newCVREF |I32 flags|NULLOK OP* o
+ApdR |OP* |newGVOP |I32 type|I32 flags|NN GV* gv
Am |GV* |newGVgen |NN const char* pack
-Apa |GV* |newGVgen_flags |NN const char* pack|U32 flags
-Apa |OP* |newGVREF |I32 type|NULLOK OP* o
-ApaR |OP* |newHVREF |NN OP* o
+ApR |GV* |newGVgen_flags |NN const char* pack|U32 flags
+ApR |OP* |newGVREF |I32 type|NULLOK OP* o
+ApR |OP* |newHVREF |NN OP* o
ApmdbR |HV* |newHV
-ApaR |HV* |newHVhv |NULLOK HV *hv
-Apabm |IO* |newIO
-Apda |OP* |newLISTOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last
-AMpdan |PADNAME *|newPADNAMEouter|NN PADNAME *outer
-AMpdan |PADNAME *|newPADNAMEpvn|NN const char *s|STRLEN len
-AMpdan |PADNAMELIST *|newPADNAMELIST|size_t max
+ApR |HV* |newHVhv |NULLOK HV *hv
+ApRbm |IO* |newIO
+ApdR |OP* |newLISTOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last
+AMpdRn |PADNAME *|newPADNAMEouter|NN PADNAME *outer
+AMpdRn |PADNAME *|newPADNAMEpvn|NN const char *s|STRLEN len
+AMpdRn |PADNAMELIST *|newPADNAMELIST|size_t max
#ifdef USE_ITHREADS
-Apda |OP* |newPADOP |I32 type|I32 flags|NN SV* sv
-#endif
-Apda |OP* |newPMOP |I32 type|I32 flags
-Apda |OP* |newPVOP |I32 type|I32 flags|NULLOK char* pv
-Apa |SV* |newRV |NN SV *const sv
-Apda |SV* |newRV_noinc |NN SV *const tmpRef
-Apda |SV* |newSV |const STRLEN len
-Apa |OP* |newSVREF |NN OP* o
-Apda |OP* |newSVOP |I32 type|I32 flags|NN SV* sv
+ApdR |OP* |newPADOP |I32 type|I32 flags|NN SV* sv
+#endif
+ApdR |OP* |newPMOP |I32 type|I32 flags
+ApdR |OP* |newPVOP |I32 type|I32 flags|NULLOK char* pv
+ApR |SV* |newRV |NN SV *const sv
+ApdR |SV* |newRV_noinc |NN SV *const tmpRef
+ApdR |SV* |newSV |const STRLEN len
+ApR |OP* |newSVREF |NN OP* o
+ApdR |OP* |newSVOP |I32 type|I32 flags|NN SV* sv
ApdR |OP* |newDEFSVOP
-pa |SV* |newSVavdefelem |NN AV *av|SSize_t ix|bool extendible
-Apda |SV* |newSViv |const IV i
-Apda |SV* |newSVuv |const UV u
-Apda |SV* |newSVnv |const NV n
-Apda |SV* |newSVpv |NULLOK const char *const s|const STRLEN len
-Apda |SV* |newSVpvn |NULLOK const char *const s|const STRLEN len
-Apda |SV* |newSVpvn_flags |NULLOK const char *const s|const STRLEN len|const U32 flags
-Apda |SV* |newSVhek |NULLOK const HEK *const hek
-Apda |SV* |newSVpvn_share |NULLOK const char* s|I32 len|U32 hash
-Apda |SV* |newSVpv_share |NULLOK const char* s|U32 hash
-Afpda |SV* |newSVpvf |NN const char *const pat|...
-Apa |SV* |vnewSVpvf |NN const char *const pat|NULLOK va_list *const args
+pR |SV* |newSVavdefelem |NN AV *av|SSize_t ix|bool extendible
+ApdR |SV* |newSViv |const IV i
+ApdR |SV* |newSVuv |const UV u
+ApdR |SV* |newSVnv |const NV n
+ApdR |SV* |newSVpv |NULLOK const char *const s|const STRLEN len
+ApdR |SV* |newSVpvn |NULLOK const char *const s|const STRLEN len
+ApdR |SV* |newSVpvn_flags |NULLOK const char *const s|const STRLEN len|const U32 flags
+ApdR |SV* |newSVhek |NULLOK const HEK *const hek
+ApdR |SV* |newSVpvn_share |NULLOK const char* s|I32 len|U32 hash
+ApdR |SV* |newSVpv_share |NULLOK const char* s|U32 hash
+AfpdR |SV* |newSVpvf |NN const char *const pat|...
+ApR |SV* |vnewSVpvf |NN const char *const pat|NULLOK va_list *const args
Apd |SV* |newSVrv |NN SV *const rv|NULLOK const char *const classname
-Apda |SV* |newSVsv |NULLOK SV *const old
-Apda |SV* |newSV_type |const svtype type
-Apda |OP* |newUNOP |I32 type|I32 flags|NULLOK OP* first
-Apda |OP* |newUNOP_AUX |I32 type|I32 flags|NULLOK OP* first \
+ApdR |SV* |newSVsv |NULLOK SV *const old
+ApdR |SV* |newSV_type |const svtype type
+ApdR |OP* |newUNOP |I32 type|I32 flags|NULLOK OP* first
+ApdR |OP* |newUNOP_AUX |I32 type|I32 flags|NULLOK OP* first \
|NULLOK UNOP_AUX_item *aux
-Apda |OP* |newWHENOP |NULLOK OP* cond|NN OP* block
-Apda |OP* |newWHILEOP |I32 flags|I32 debuggable|NULLOK LOOP* loop \
+ApdR |OP* |newWHENOP |NULLOK OP* cond|NN OP* block
+ApdR |OP* |newWHILEOP |I32 flags|I32 debuggable|NULLOK LOOP* loop \
|NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \
|I32 has_my
-Apda |OP* |newMETHOP |I32 type|I32 flags|NN OP* dynamic_meth
-Apda |OP* |newMETHOP_named|I32 type|I32 flags|NN SV* const_meth
+ApdR |OP* |newMETHOP |I32 type|I32 flags|NN OP* dynamic_meth
+ApdR |OP* |newMETHOP_named|I32 type|I32 flags|NN SV* const_meth
Apd |CV* |rv2cv_op_cv |NN OP *cvop|U32 flags
Apd |OP* |ck_entersub_args_list|NN OP *entersubop
Apd |OP* |ck_entersub_args_proto|NN OP *entersubop|NN GV *namegv|NN SV *protosv
|NN Perl_call_checker ckfun \
|NN SV *ckobj|U32 flags
Apd |void |wrap_op_checker|Optype opcode|NN Perl_check_t new_checker|NN Perl_check_t *old_checker_p
-Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
+ApR |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
Ap |char* |scan_vstring |NN const char *s|NN const char *const e \
|NN SV *sv
Apd |const char* |scan_version |NN const char *s|NN SV *rv|bool qv
#endif
: exported for re.pm
EXp |MAGIC *|sv_magicext_mglob|NN SV *sv
-ApdbamR |SV* |sv_mortalcopy |NULLOK SV *const oldsv
-XpaR |SV* |sv_mortalcopy_flags|NULLOK SV *const oldsv|U32 flags
+ApdbmR |SV* |sv_mortalcopy |NULLOK SV *const oldsv
+XpR |SV* |sv_mortalcopy_flags|NULLOK SV *const oldsv|U32 flags
ApdR |SV* |sv_newmortal
Apd |SV* |sv_newref |NULLOK SV *const sv
Ap |char* |sv_peek |NULLOK SV* sv
ApM |UV |swash_fetch |NN SV *swash|NN const U8 *ptr|bool do_utf8
#ifdef PERL_IN_REGCOMP_C
EiMR |SV* |add_cp_to_invlist |NULLOK SV* invlist|const UV cp
-EiMRn |UV* |_invlist_array_init |NN SV* const invlist|const bool will_have_0
-EiMRn |UV |invlist_max |NN SV* const invlist
EiM |void |invlist_set_len|NN SV* const invlist|const UV len|const bool offset
EiMRn |bool |invlist_is_iterating|NN SV* const invlist
#ifndef PERL_EXT_RE_BUILD
+EiMRn |UV* |_invlist_array_init |NN SV* const invlist|const bool will_have_0
+EiMRn |UV |invlist_max |NN SV* const invlist
EsM |void |_append_range_to_invlist |NN SV* const invlist|const UV start|const UV end
EsM |void |invlist_extend |NN SV* const invlist|const UV len
EsM |void |invlist_replace_list_destroys_src|NN SV *dest|NN SV *src
#endif
Anpa |Malloc_t|safesysmalloc |MEM_SIZE nbytes
Anpa |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size
-Anpa |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes
+AnpR |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes
Anp |Free_t |safesysfree |Malloc_t where
Asrnx |void |croak_memory_wrap
#if defined(PERL_GLOBAL_STRUCT)
#if defined(USE_ITHREADS)
ApR |PERL_CONTEXT*|cx_dup |NULLOK PERL_CONTEXT* cx|I32 ix|I32 max|NN CLONE_PARAMS* param
ApR |PERL_SI*|si_dup |NULLOK PERL_SI* si|NN CLONE_PARAMS* param
-Apa |ANY* |ss_dup |NN PerlInterpreter* proto_perl|NN CLONE_PARAMS* param
+ApR |ANY* |ss_dup |NN PerlInterpreter* proto_perl|NN CLONE_PARAMS* param
ApR |void* |any_dup |NULLOK void* v|NN const PerlInterpreter* proto_perl
ApR |HE* |he_dup |NULLOK const HE* e|bool shared|NN CLONE_PARAMS* param
ApR |HEK* |hek_dup |NULLOK HEK* e|NN CLONE_PARAMS* param
Ap |void |rvpv_dup |NN SV *const dstr|NN const SV *const sstr|NN CLONE_PARAMS *const param
Ap |yy_parser*|parser_dup |NULLOK const yy_parser *const proto|NN CLONE_PARAMS *const param
#endif
-Apa |PTR_TBL_t*|ptr_table_new
+ApR |PTR_TBL_t*|ptr_table_new
ApR |void* |ptr_table_fetch|NN PTR_TBL_t *const tbl|NULLOK const void *const sv
Ap |void |ptr_table_store|NN PTR_TBL_t *const tbl|NULLOK const void *const oldsv \
|NN void *const newsv
|STRLEN len|const U32 is_utf8|const I32 add \
|const svtype sv_type
s |bool|gv_magicalize|NN GV *gv|NN HV *stash|NN const char *name \
- |STRLEN len|bool addmg \
+ |STRLEN len \
|const svtype sv_type
s |void|maybe_multimagic_gv|NN GV *gv|NN const char *name|const svtype sv_type
s |bool|gv_is_in_main|NN const char *name|STRLEN len \
|const U32 is_utf8
-s |HV* |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \
- |NN const char *methpv|const U32 flags
+s |void |require_tie_mod|NN GV *gv|NN const char varname \
+ |NN const char * name|STRLEN len \
+ |const U32 flags
#endif
#if defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)
s |void |hsplit |NN HV *hv|STRLEN const oldsize|STRLEN newsize
s |void |hfreeentries |NN HV *hv
s |SV* |hv_free_ent_ret|NN HV *hv|NN HE *entry
-sa |HE* |new_he
+sR |HE* |new_he
sanR |HEK* |save_hek_flags |NN const char *str|I32 len|U32 hash|int flags
sn |void |hv_magic_check |NN HV *hv|NN bool *needs_copy|NN bool *needs_store
s |void |unshare_hek_or_pvn|NULLOK const HEK* hek|NULLOK const char* str|I32 len|U32 hash
s |void |clear_special_blocks |NN const char *const fullname\
|NN GV *const gv|NN CV *const cv
#endif
-Xpa |void* |Slab_Alloc |size_t sz
+XpR |void* |Slab_Alloc |size_t sz
Xp |void |Slab_Free |NN void *op
#if defined(PERL_DEBUG_READONLY_OPS)
# if defined(PERL_CORE)
# if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
sR |int |dooneliner |NN const char *cmd|NN const char *filename
# endif
-s |SV * |space_join_names_mortal|NN char *const *array
+s |SV * |space_join_names_mortal|NULLOK char *const *array
#endif
p |OP * |tied_method|NN SV *methname|NN SV **sp \
|NN SV *const sv|NN const MAGIC *const mg \
#if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
s |char* |stdize_locale |NN char* locs
+# ifdef DEBUGGING
+s |void |print_collxfrm_input_and_return \
+ |NN const char * const s \
+ |NN const char * const e \
+ |NULLOK const STRLEN * const xlen \
+ |const bool is_utf8
+# endif
#endif
#if defined(USE_LOCALE) \
Apmd |STRLEN |sv_utf8_upgrade_flags|NN SV *const sv|const I32 flags
Ap |STRLEN |sv_utf8_upgrade_flags_grow|NN SV *const sv|const I32 flags|STRLEN extra
Apd |char* |sv_pvn_force_flags|NN SV *const sv|NULLOK STRLEN *const lp|const I32 flags
-pmb |void |sv_copypv |NN SV *const dsv|NN SV *const ssv
+Apmb |void |sv_copypv |NN SV *const dsv|NN SV *const ssv
Apmd |void |sv_copypv_nomg |NN SV *const dsv|NN SV *const ssv
Apd |void |sv_copypv_flags |NN SV *const dsv|NN SV *const ssv|const I32 flags
Ap |char* |my_atof2 |NN const char *s|NN NV* value
#endif
: pad API
-Apda |PADLIST*|pad_new |int flags
+ApdR |PADLIST*|pad_new |int flags
#ifdef DEBUGGING
pnX |void|set_padlist| NN CV * cv | NULLOK PADLIST * padlist
#endif
Apo |bool |ckwarn |U32 w
Apo |bool |ckwarn_d |U32 w
: FIXME - exported for ByteLoader - public or private?
-XEopMa |STRLEN *|new_warnings_bitfield|NULLOK STRLEN *buffer \
+XEopMR |STRLEN *|new_warnings_bitfield|NULLOK STRLEN *buffer \
|NN const char *const bits|STRLEN size
#ifndef SPRINTF_RETURNS_STRLEN
# if defined(PERL_IN_SV_C)
s |void |unreferenced_to_tmp_stack|NN AV *const unreferenced
# endif
-Aanop |CLONE_PARAMS *|clone_params_new|NN PerlInterpreter *const from \
+ARnop |CLONE_PARAMS *|clone_params_new|NN PerlInterpreter *const from \
|NN PerlInterpreter *const to
Anop |void |clone_params_del|NN CLONE_PARAMS *param
#endif
# if !defined(PERL_EXT_RE_BUILD)
# if defined(PERL_IN_REGCOMP_C)
#define _append_range_to_invlist(a,b,c) S__append_range_to_invlist(aTHX_ a,b,c)
+#define _invlist_array_init S__invlist_array_init
#define get_invlist_previous_index_addr S_get_invlist_previous_index_addr
#define invlist_clear(a) S_invlist_clear(aTHX_ a)
#define invlist_extend(a,b) S_invlist_extend(aTHX_ a,b)
+#define invlist_max S_invlist_max
#define invlist_previous_index S_invlist_previous_index
#define invlist_replace_list_destroys_src(a,b) S_invlist_replace_list_destroys_src(aTHX_ a,b)
#define invlist_set_previous_index S_invlist_set_previous_index
#define sv_or_pv_pos_u2b(a,b,c,d) S_sv_or_pv_pos_u2b(aTHX_ a,b,c,d)
# endif
# if defined(PERL_IN_REGCOMP_C)
-#define _invlist_array_init S__invlist_array_init
#define _make_exactf_invlist(a,b) S__make_exactf_invlist(aTHX_ a,b)
#define add_above_Latin1_folds(a,b,c) S_add_above_Latin1_folds(aTHX_ a,b,c)
#define add_cp_to_invlist(a,b) S_add_cp_to_invlist(aTHX_ a,b)
#define invlist_iterfinish S_invlist_iterfinish
#define invlist_iterinit S_invlist_iterinit
#define invlist_iternext S_invlist_iternext
-#define invlist_max S_invlist_max
#define invlist_set_len(a,b,c) S_invlist_set_len(aTHX_ a,b,c)
#define is_ssc_worth_it S_is_ssc_worth_it
#define join_exact(a,b,c,d,e,f,g) S_join_exact(aTHX_ a,b,c,d,e,f,g)
#ifdef PERL_CORE
#define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a)
#define Slab_Free(a) Perl_Slab_Free(aTHX_ a)
+#define alloc_LOGOP(a,b,c) Perl_alloc_LOGOP(aTHX_ a,b,c)
#define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c)
#define amagic_is_enabled(a) Perl_amagic_is_enabled(aTHX_ a)
#define apply(a,b,c) Perl_apply(aTHX_ a,b,c)
#define core_prototype(a,b,c,d) Perl_core_prototype(aTHX_ a,b,c,d)
#define coresub_op(a,b,c) Perl_coresub_op(aTHX_ a,b,c)
#define create_eval_scope(a,b) Perl_create_eval_scope(aTHX_ a,b)
+#define croak_caller Perl_croak_caller
#define croak_no_mem Perl_croak_no_mem
#define croak_popstack Perl_croak_popstack
#define custom_op_get_field(a,b) Perl_custom_op_get_field(aTHX_ a,b)
#define pad_push(a,b) Perl_pad_push(aTHX_ a,b)
#define pad_swipe(a,b) Perl_pad_swipe(aTHX_ a,b)
#define padlist_store(a,b,c) Perl_padlist_store(aTHX_ a,b,c)
-#define parse_subsignature() Perl_parse_subsignature(aTHX)
#define parse_unicode_opts(a) Perl_parse_unicode_opts(aTHX_ a)
#define parser_free(a) Perl_parser_free(aTHX_ a)
#define peep(a) Perl_peep(aTHX_ a)
#define printbuf(a,b) S_printbuf(aTHX_ a,b)
#define tokereport(a,b) S_tokereport(aTHX_ a,b)
# endif
+# if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
+#define print_collxfrm_input_and_return(a,b,c,d) S_print_collxfrm_input_and_return(aTHX_ a,b,c,d)
+# endif
# endif
# if defined(DEBUG_LEAKING_SCALARS_FORK_DUMP)
#define dump_sv_child(a) Perl_dump_sv_child(aTHX_ a)
#define gv_fetchmeth_internal(a,b,c,d,e,f) S_gv_fetchmeth_internal(aTHX_ a,b,c,d,e,f)
#define gv_init_svtype(a,b) S_gv_init_svtype(aTHX_ a,b)
#define gv_is_in_main(a,b,c) S_gv_is_in_main(aTHX_ a,b,c)
-#define gv_magicalize(a,b,c,d,e,f) S_gv_magicalize(aTHX_ a,b,c,d,e,f)
+#define gv_magicalize(a,b,c,d,e) S_gv_magicalize(aTHX_ a,b,c,d,e)
#define gv_magicalize_isa(a) S_gv_magicalize_isa(aTHX_ a)
#define gv_stashpvn_internal(a,b,c) S_gv_stashpvn_internal(aTHX_ a,b,c)
#define gv_stashsvpvn_cached(a,b,c,d) S_gv_stashsvpvn_cached(aTHX_ a,b,c,d)
#define PL_markstack_max (vTHX->Imarkstack_max)
#define PL_markstack_ptr (vTHX->Imarkstack_ptr)
#define PL_max_intro_pending (vTHX->Imax_intro_pending)
-#define PL_maxo (vTHX->Imaxo)
#define PL_maxsysfd (vTHX->Imaxsysfd)
#define PL_memory_debug_header (vTHX->Imemory_debug_header)
#define PL_mess_sv (vTHX->Imess_sv)
#if defined(PERL_GLOBAL_STRUCT)
+#define PL_C_locale_obj (my_vars->GC_locale_obj)
+#define PL_GC_locale_obj (my_vars->GC_locale_obj)
#define PL_appctx (my_vars->Gappctx)
#define PL_Gappctx (my_vars->Gappctx)
#define PL_check (my_vars->Gcheck)
# walkoptree comes from B.xs
BEGIN {
- $B::VERSION = '1.62';
+ $B::VERSION = '1.63';
@B::EXPORT_OK = ();
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
B::CV cv
PREINIT:
SV *ret;
+ UNOP_AUX_item *aux;
PPCODE:
+ aux = cUNOP_AUXo->op_aux;
switch (o->op_type) {
case OP_MULTIDEREF:
ret = multideref_stringify(o, cv);
break;
+
+ case OP_ARGELEM:
+ ret = sv_2mortal(Perl_newSVpvf(aTHX_ "%"IVdf,
+ PTR2IV(aux)));
+ break;
+
+ case OP_ARGCHECK:
+ ret = Perl_newSVpvf(aTHX_ "%"IVdf",%"IVdf, aux[0].iv, aux[1].iv);
+ if (aux[2].iv)
+ Perl_sv_catpvf(aTHX_ ret, ",%c", (char)aux[2].iv);
+ ret = sv_2mortal(ret);
+ break;
+
default:
ret = sv_2mortal(newSVpvn("", 0));
}
+
ST(0) = ret;
XSRETURN(1);
aux_list(o, cv)
B::OP o
B::CV cv
+ PREINIT:
+ UNOP_AUX_item *aux;
PPCODE:
PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */
+ aux = cUNOP_AUXo->op_aux;
switch (o->op_type) {
default:
XSRETURN(0); /* by default, an empty list */
+ case OP_ARGELEM:
+ XPUSHs(sv_2mortal(newSViv(PTR2IV(aux))));
+ XSRETURN(1);
+ break;
+
+ case OP_ARGCHECK:
+ EXTEND(SP, 3);
+ PUSHs(sv_2mortal(newSViv(aux[0].iv)));
+ PUSHs(sv_2mortal(newSViv(aux[1].iv)));
+ PUSHs(sv_2mortal(aux[2].iv ? Perl_newSVpvf(aTHX_ "%c",
+ (char)aux[2].iv) : &PL_sv_no));
+ break;
+
case OP_MULTIDEREF:
#ifdef USE_ITHREADS
# define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
use Exporter (); # use #5
-our $VERSION = "0.996";
+our $VERSION = "0.998";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
our %hints; # used to display each COP's op_hints values
# strict refs, subs, vars
-@hints{2,512,1024,32,64,128} = ('$', '&', '*', 'x$', 'x&', 'x*');
+@hints{0x2,0x200,0x400,0x20,0x40,0x80} = ('$', '&', '*', 'x$', 'x&', 'x*');
# integers, locale, bytes
-@hints{1,4,8,16} = ('i', 'l', 'b');
+@hints{0x1,0x4,0x8,0x10} = ('i', 'l', 'b');
# block scope, localise %^H, $^OPEN (in), $^OPEN (out)
-@hints{256,131072,262144,524288} = ('{','%','<','>');
+@hints{0x100,0x20000,0x40000,0x80000} = ('{','%','<','>');
# overload new integer, float, binary, string, re
-@hints{4096,8192,16384,32768,65536} = ('I', 'F', 'B', 'S', 'R');
+@hints{0x1000,0x2000,0x4000,0x8000,0x10000} = ('I', 'F', 'B', 'S', 'R');
# taint and eval
-@hints{1048576,2097152} = ('T', 'E');
-# filetest access, UTF-8
-@hints{4194304,8388608} = ('X', 'U');
+@hints{0x100000,0x200000} = ('T', 'E');
+# filetest access, use utf8, unicode_strings feature
+@hints{0x400000,0x800000,0x800} = ('X', 'U', 'us');
-sub _flags {
- my($hash, $x) = @_;
+# pick up the feature hints constants.
+# Note that we're relying on non-API parts of feature.pm,
+# but its less naughty than just blindly copying those constants into
+# this src file.
+#
+require feature;
+
+sub hints_flags {
+ my($x) = @_;
my @s;
- for my $flag (sort {$b <=> $a} keys %$hash) {
- if ($hash->{$flag} and $x & $flag and $x >= $flag) {
+ for my $flag (sort {$b <=> $a} keys %hints) {
+ if ($hints{$flag} and $x & $flag and $x >= $flag) {
$x -= $flag;
- push @s, $hash->{$flag};
+ push @s, $hints{$flag};
}
}
- push @s, $x if $x;
+ if ($x & $feature::hint_mask) {
+ push @s, "fea=" . (($x & $feature::hint_mask) >> $feature::hint_shift);
+ $x &= ~$feature::hint_mask;
+ }
+ push @s, sprintf "0x%x", $x if $x;
return join(",", @s);
}
+
# return a string like 'LVINTRO,1' for the op $name with op_private
# value $x
return join ",", @flags;
}
-sub hints_flags {
- my($x) = @_;
- _flags(\%hints, $x);
-}
-
sub concise_sv {
my($sv, $hr, $preferpv) = @_;
$hr->{svclass} = class($sv);
$h{targarg} = join '; ', @targarg;
$h{targarglife} = join '; ', @targarglife;
}
+
$h{arg} = "";
$h{svclass} = $h{svaddr} = $h{svval} = "";
if ($h{class} eq "PMOP") {
undef $lastnext;
$h{arg} = "(other->" . seq($op->other) . ")";
$h{otheraddr} = sprintf("%#x", $ {$op->other});
+ if ($h{name} eq "argdefelem") {
+ # targ used for element index
+ $h{targarglife} = $h{targarg} = "";
+ $h{arg} .= "[" . $op->targ . "]";
+ }
}
elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
X filetest access
U utf-8
+ us use feature 'unicode_strings'
+ fea=NNN feature bundle number
+
=item B<#hintsval>
The numeric value of the COP's hint flags, or an empty string if this is not
require 'test.pl'; # we use runperl from 'test.pl', so can't use Test::More
}
-plan tests => 163;
+plan tests => 167;
require_ok("B::Concise");
like $out, qr/$end/, 'OP_AND->op_other points correctly';
+# test nextstate hints display
+
+{
+
+ $out = runperl(
+ switches => ["-MO=Concise"],
+ prog => q{my $x; use strict; use warnings; $x++; use feature q(:5.11); $x++},
+ stderr => 1,
+ );
+
+ my @hints = $out =~ /nextstate\([^)]+\) (.*) ->/g;
+
+ is(scalar(@hints), 3, "3 hints");
+ is($hints[0], 'v:{', "hints[0]");
+ is($hints[1], 'v:*,&,{,x*,x&,x$,$', "hints[1]");
+ is($hints[2], 'v:%,us,*,&,{,x*,x&,x$,$,fea=7', "hints[2]");
+}
+
__END__
use Config;
use strict;
-our $VERSION = "1.25";
+our $VERSION = "1.26";
my %err = ();
Carp::confess("ERRNO hash is read only!");
}
+# This is the true return value
*CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
sub NEXTKEY {
exists $err{$errname};
}
-tie %!, __PACKAGE__; # Returns an object, objects are true.
+sub _tie_it {
+ tie %{$_[0]}, __PACKAGE__;
+}
__END__
MODULE = Hash::Util PACKAGE = Hash::Util
+void
+_clear_placeholders(hashref)
+ HV *hashref
+ PROTOTYPE: \%
+ PREINIT:
+ HV *hv;
+ CODE:
+ hv = MUTABLE_HV(hashref);
+ hv_clear_placeholders(hv);
+
void
all_keys(hash,keys,placeholder)
HV *hash
XSRETURN(0);
}
-#if PERL_VERSION < 25
-SV*
+void
bucket_ratio(rhv)
SV* rhv
PROTOTYPE: \%
if (SvROK(rhv)) {
rhv= SvRV(rhv);
if ( SvTYPE(rhv)==SVt_PVHV ) {
+#if PERL_VERSION < 25
SV *ret= Perl_hv_scalar(aTHX_ (HV*)rhv);
+#else
+ SV *ret= Perl_hv_bucket_ratio(aTHX_ (HV*)rhv);
+#endif
ST(0)= ret;
XSRETURN(1);
}
XSRETURN_UNDEF;
}
-SV*
+void
num_buckets(rhv)
SV* rhv
PROTOTYPE: \%
XSRETURN_UNDEF;
}
-SV*
+void
used_buckets(rhv)
SV* rhv
PROTOTYPE: \%
XSRETURN_UNDEF;
}
-#endif
used_buckets
num_buckets
);
-our $VERSION = '0.20';
-require XSLoader;
-XSLoader::load();
+BEGIN {
+ # make sure all our XS routines are available early so their prototypes
+ # are correctly applied in the following code.
+ our $VERSION = '0.21';
+ require XSLoader;
+ XSLoader::load();
+}
sub import {
my $class = shift;
sub lock_ref_keys {
my($hash, @keys) = @_;
- Internals::hv_clear_placeholders %$hash;
+ _clear_placeholders(%$hash);
if( @keys ) {
my %keys = map { ($_ => 1) } @keys;
my %original_keys = map { ($_ => 1) } keys %$hash;
sub lock_keys (\%;@) { lock_ref_keys(@_) }
sub unlock_keys (\%) { unlock_ref_keys(@_) }
+#=item B<_clear_placeholders>
+#
+# This function removes any placeholder keys from a hash. See Perl_hv_clear_placeholders()
+# in hv.c for what it does exactly. It is currently exposed as XS by universal.c and
+# injected into the Hash::Util namespace.
+#
+# It is not intended for use outside of this module, and may be changed
+# or removed without notice or deprecation cycle.
+#
+#=cut
+#
+# sub _clear_placeholders {} # just in case someone searches...
+
=item B<lock_keys_plus>
lock_keys_plus(%hash,@additional_keys)
sub lock_ref_keys_plus {
my ($hash,@keys) = @_;
my @delete;
- Internals::hv_clear_placeholders(%$hash);
+ _clear_placeholders(%$hash);
foreach my $key (@keys) {
unless (exists($hash->{$key})) {
$hash->{$key}=undef;
our($VERSION, @ISA, @EXPORT_OK);
-$VERSION = "1.35";
+$VERSION = "1.37";
use Carp;
use Exporter ();
av2arylen
rv2hv helem hslice kvhslice each values keys exists delete
- aeach akeys avalues multideref
+ aeach akeys avalues multideref argelem argdefelem argcheck
preinc i_preinc predec i_predec postinc i_postinc
postdec i_postdec int hex oct abs pow multiply i_multiply
int i;
STRLEN len;
char **op_names;
- char *bitmap;
+ U8 *bitmap;
dMY_CXT;
op_named_bits = newHV();
put_op_bitspec(aTHX_ STR_WITH_LEN(":none"), sv_2mortal(new_opset(aTHX_ Nullsv)));
opset_all = new_opset(aTHX_ Nullsv);
- bitmap = SvPV(opset_all, len);
+ bitmap = (U8*)SvPV(opset_all, len);
memset(bitmap, 0xFF, len-1); /* deal with last byte specially, see below */
/* Take care to set the right number of bits in the last byte */
- bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF;
+ bitmap[len-1] = (PL_maxo & 0x07) ? ((~(0xFF << (PL_maxo & 0x07))) & 0xFF)
+ : 0xFF;
put_op_bitspec(aTHX_ STR_WITH_LEN(":all"), opset_all); /* don't mortalise */
}
# define NV_PAYLOAD_TYPE NV
#endif
-#ifdef LONGDOUBLE_DOUBLEDOUBLE
-# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE / 2)
+#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
+# define NV_PAYLOAD_SIZEOF_ASSERT(a) \
+ STATIC_ASSERT_STMT(sizeof(a) == NVSIZE / 2)
#else
-# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE)
+# define NV_PAYLOAD_SIZEOF_ASSERT(a) \
+ STATIC_ASSERT_STMT(sizeof(a) == NVSIZE)
#endif
static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.70';
+our $VERSION = '1.71';
require XSLoader;
=cut
+BEGIN { pop @INC if $INC[-1] eq '.' }
use Pod::Html;
pod2html @ARGV;
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = 1.22;
+$VERSION = 1.2201;
@ISA = qw(Exporter);
@EXPORT = qw(pod2html htmlify);
@EXPORT_OK = qw(anchorify);
use strict;
package Tie::Hash::NamedCapture;
-our $VERSION = "0.09";
+our $VERSION = "0.10";
require XSLoader;
XSLoader::load(); # This returns true, which makes require happy.
#define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
#define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
-static void
-tie_it(pTHX_ const char name, UV flag, HV *const stash)
-{
- GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV);
- HV *const hv = GvHV(gv);
- SV *rv = newSV_type(SVt_RV);
+MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture
+PROTOTYPES: DISABLE
- SvRV_set(rv, newSVuv(flag));
+void
+_tie_it(SV *sv)
+ INIT:
+ GV * const gv = (GV *)sv;
+ HV * const hv = GvHVn(gv);
+ SV *rv = newSV_type(SVt_RV);
+ CODE:
+ SvRV_set(rv, newSVuv(*GvNAME(gv) == '-' ? RXapif_ALL : RXapif_ONE));
SvROK_on(rv);
- sv_bless(rv, stash);
+ sv_bless(rv, GvSTASH(CvGV(cv)));
sv_unmagic((SV *)hv, PERL_MAGIC_tied);
sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
-}
-
-MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture
-PROTOTYPES: DISABLE
-
-BOOT:
- {
- HV *const stash = GvSTASH(CvGV(cv));
- tie_it(aTHX_ '-', RXapif_ALL, stash);
- tie_it(aTHX_ '+', RXapif_ONE, stash);
- }
SV *
TIEHASH(package, ...)
use warnings;
use Carp;
-our $VERSION = '0.82';
+our $VERSION = '0.83';
require XSLoader;
/* We want to be able to test things that aren't API yet. */
#define PERL_EXT
+/* Do *not* define PERL_NO_GET_CONTEXT. This is the one place where we get
+ to test implicit Perl_get_context(). */
+
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
EXTEND(SP, 1);
PUSHs(sv_2mortal(newSViv(i)));
+void
+call_argv(subname, flags, ...)
+ char* subname
+ I32 flags
+ PREINIT:
+ I32 i;
+ char *tmpary[4];
+ PPCODE:
+ for (i=0; i<items-2; i++)
+ tmpary[i] = SvPV_nolen(ST(i+2)); /* ignore first two args */
+ tmpary[i] = NULL;
+ PUTBACK;
+ i = call_argv(subname, flags, tmpary);
+ SPAGAIN;
+ EXTEND(SP, 1);
+ PUSHs(sv_2mortal(newSViv(i)));
+
void
call_method(methname, flags, ...)
char* methname
OUTPUT:
RETVAL
+bool
+test_isOCTAL_A(UV ord)
+ CODE:
+ RETVAL = isOCTAL_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isOCTAL_L1(UV ord)
+ CODE:
+ RETVAL = isOCTAL_L1(ord);
+ OUTPUT:
+ RETVAL
+
bool
test_isIDFIRST_uni(UV ord)
CODE:
BEGIN {
require '../../t/test.pl';
- plan(455);
+ plan(527);
use_ok('XS::APItest')
};
ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
"$description call_pv('f')");
+ ok(eq_array( [ call_argv('f', $flags, @$args) ], $expected),
+ "$description call_argv('f')") or warn "@{[call_argv('f', $flags, @$args)]}";
+
ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
$expected), "$description eval_sv('f(args)')");
is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning");
+ $@ = "before\n";
+ $warn = "";
+ ok(eq_array( [ call_argv('d', $flags|G_EVAL|$keep, @$args) ],
+ $returnval),
+ "$desc G_EVAL call_argv('d')");
+ is($@, $exp_err, "$desc G_EVAL call_argv('d') - \$@");
+ is($warn, $exp_warn, "$desc G_EVAL call_argv('d') - warning");
+
$@ = "before\n";
$warn = "";
ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
$expected), "$description G_NOARGS call_pv('f')");
+ ok(eq_array( [ sub { call_argv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
+ $expected), "$description G_NOARGS call_argv('f')");
+
ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
$expected), "$description G_NOARGS eval_sv('f(@_)')");
ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
[ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
+ ok(eq_array( [ eval { call_argv('d', $flags, @$args) }, $@ ],
+ [ "its_dead_jim\n" ]), "$description eval { call_argv('d') }");
+
ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
[ @$returnval,
"its_dead_jim\n", '' ]),
}
}
+# Test isOCTAL()
+for my $i (0 .. 256, 0x110000) {
+ my $char_name = charnames::viacode($i) // "No name";
+ my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
+ my $truth = truth($i >= ord('0') && $i <= ord('7'));
+
+ my $ret = truth test_isOCTAL_A($i);
+ is($ret, $truth, "isOCTAL_A( $display_name ) == $truth");
+
+ $ret = truth test_isOCTAL_L1($i);
+ is($ret, $truth, "isOCTAL_L1( $display_name ) == $truth");
+}
+
my %to_properties = (
FOLD => 'Case_Folding',
LOWER => 'Lowercase_Mapping',
package arybase;
-our $VERSION = "0.11";
+our $VERSION = "0.12";
require XSLoader;
XSLoader::load(); # This returns true, which makes require happy.
BOOT:
{
- GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PV);
- sv_unmagic(GvSV(gv), PERL_MAGIC_sv); /* This is *our* scalar now! */
- tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv)));
-
if (!ab_initialized++) {
ab_op_map = ptable_new();
#ifdef USE_ITHREADS
}
}
+void
+_tie_it(SV *sv)
+ INIT:
+ GV * const gv = (GV *)sv;
+ CODE:
+ if (GvSV(gv))
+ /* This is *our* scalar now! */
+ sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
+ tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
+
void
FETCH(...)
PREINIT:
/* require_tie_mod() internal routine for requiring a module
* that implements the logic of automatic ties like %! and %-
+ * It loads the module and then calls the _tie_it subroutine
+ * with the passed gv as an argument.
*
* The "gv" parameter should be the glob.
- * "varpv" holds the name of the var, used for error messages.
+ * "varname" holds the 1-char name of the var, used for error messages.
* "namesv" holds the module name. Its refcount will be decremented.
- * "methpv" holds the method name to test for to check that things
- * are working reasonably close to as expected.
* "flags": if flag & 1 then save the scalar before loading.
* For the protection of $! to work (it is set by this routine)
* the sv slot must already be magicalized.
*/
-STATIC HV*
-S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
+STATIC void
+S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
+ STRLEN len, const U32 flags)
{
- HV* stash = gv_stashsv(namesv, 0);
+ const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
- if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
- SV *module = newSVsv(namesv);
- char varname = *varpv; /* varpv might be clobbered by load_module,
- so save it. For the moment it's always
- a single char. */
+ /* If it is not tied */
+ if (!target || !SvRMAGICAL(target)
+ || !mg_find(target,
+ varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
+ {
+ HV *stash;
+ GV **gvp;
+ dSP;
+
+ ENTER;
+
+#define HV_FETCH_TIE_FUNC (GV **)hv_fetch(stash, "_tie_it", 7, 0)
+
+ /* Load the module if it is not loaded. */
+ if (!(stash = gv_stashpvn(name, len, 0))
+ || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+ {
+ SV * const module = newSVpvn(name, len);
const char type = varname == '[' ? '$' : '%';
-#ifdef DEBUGGING
- dSP;
-#endif
- ENTER;
- SAVEFREESV(namesv);
if ( flags & 1 )
save_scalar(gv);
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
assert(sp == PL_stack_sp);
- stash = gv_stashsv(namesv, 0);
+ stash = gv_stashpvn(name, len, 0);
if (!stash)
- Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
- type, varname, SVfARG(namesv));
- else if (!gv_fetchmethod(stash, methpv))
- Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
- type, varname, SVfARG(namesv), methpv);
- LEAVE;
+ Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
+ type, varname, name);
+ else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+ Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
+ type, varname, name);
+ }
+ /* Now call the tie function. It should be in *gvp. */
+ assert(gvp); assert(*gvp); assert(GvCV(*gvp));
+ PUSHMARK(SP);
+ XPUSHs((SV *)gv);
+ PUTBACK;
+ call_sv((SV *)*gvp, G_VOID|G_DISCARD);
+ LEAVE;
}
- else SvREFCNT_dec_NN(namesv);
- return stash;
}
/*
gv_stashsvpvn_cached
Returns a pointer to the stash for a specified package, possibly
-cached. Implements both C<gv_stashpvn> and C<gc_stashsv>.
+cached. Implements both C<gv_stashpvn> and C<gv_stashsv>.
Requires one of either namesv or namepv to be non-null.
* Note that it does not insert the GV into the stash prior to
* magicalization, which some variables require need in order
* to work (like $[, %+, %-, %!), so callers must take care of
- * that beforehand.
+ * that.
*
- * The return value has a specific meaning for gv_fetchpvn_flags:
- * If it returns true, and the gv is empty, it indicates that its
- * refcount should be decreased.
+ * It returns true if the gv did turn out to be magical one; i.e.,
+ * if gv_magicalize actually did something.
*/
PERL_STATIC_INLINE bool
S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
- bool addmg, const svtype sv_type)
+ const svtype sv_type)
{
SSize_t paren;
GvMULTI_on(gv);
break;
case 'a':
+ if (stash == PL_debstash && len==4 && strEQ(name2,"rgs")) {
+ GvMULTI_on(gv_AVadd(gv));
+ break;
+ }
case 'b':
if (len == 1 && sv_type == SVt_PV)
GvMULTI_on(gv);
default:
goto try_core;
}
- return addmg;
+ goto ret;
}
try_core:
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
this test */
UV uv;
if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
- return addmg;
+ goto ret;
/* XXX why are we using a SSize_t? */
paren = (SSize_t)(I32)uv;
goto storeparen;
/* magicalization must be done before require_tie_mod is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- {
- require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
- addmg = FALSE;
- }
+ require_tie_mod(gv, '!', "Errno", 5, 1);
break;
case '-': /* $- */
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- {
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
- addmg = FALSE;
- }
+ require_tie_mod(gv, *name, "Tie::Hash::NamedCapture",23,0);
break;
}
case '[': /* $[ */
if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
&& FEATURE_ARYBASE_IS_ENABLED) {
- require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
- addmg = FALSE;
+ require_tie_mod(gv,'[',"arybase",7,0);
}
else goto magicalize;
break;
}
}
- return addmg;
+ ret:
+ /* Return true if we actually did something. */
+ return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
+ || ( GvSV(gv) && (
+ SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
+ )
+ );
}
/* If we do ever start using this later on in the file, we need to make
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
if (*name == '!')
- require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+ require_tie_mod(gv, '!', "Errno", 5, 1);
else if (*name == '-' || *name == '+')
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ require_tie_mod(gv, *name, "Tie::Hash::NamedCapture", 23, 0);
} else if (sv_type == SVt_PV) {
if (*name == '*' || *name == '#') {
/* diag_listed_as: $* is no longer supported */
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
switch (*name) {
case '[':
- require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ require_tie_mod(gv,'[',"arybase",7,0);
break;
#ifdef PERL_SAWAMPERSAND
case '`':
if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
GvMULTI_on(gv) ;
- /* First, store the gv in the symtab if we're adding magic,
- * but only for non-empty GVs
- */
-#define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
- || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
-
- if ( addmg && !GvEMPTY(gv) ) {
- (void)hv_store(stash,name,len,(SV *)gv,0);
- }
-
/* set up magic where warranted */
- if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
+ if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
/* See 23496c6 */
- if (GvEMPTY(gv)) {
- if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
- /* The GV was and still is "empty", except that now
- * it has the magic flags turned on, so we want it
+ if (addmg) {
+ /* gv_magicalize magicalised this gv, so we want it
* stored in the symtab.
+ * Effectively the caller is asking, ‘Does this gv exist?’
+ * And we respond, ‘Er, *now* it does!’
*/
(void)hv_store(stash,name,len,(SV *)gv,0);
- }
- else {
- /* Most likely the temporary GV created above */
+ }
+ }
+ else if (addmg) {
+ /* The temporary GV created above */
SvREFCNT_dec_NN(gv);
gv = NULL;
- }
- }
}
if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
* of operands. Well, they are, but that is kind of the point.
*/
#ifndef __COVERITY__
-#define FITS_IN_8_BITS(c) ((sizeof(c) == 1) || !(((WIDEST_UTYPE)(c)) & ~0xFF))
+ /* The '| 0' part ensures a compiler error if c is not integer (like e.g., a
+ * pointer) */
+#define FITS_IN_8_BITS(c) ( (sizeof(c) == 1) \
+ || !(((WIDEST_UTYPE)((c) | 0)) & ~0xFF))
#else
#define FITS_IN_8_BITS(c) (1)
#endif
/* There is a simple definition of ASCII for ASCII platforms. But the
* EBCDIC one isn't so simple, so is defined using table look-up like the
* other macros below.
- * The '| 0' part ensures that c is an integer (and not e.g. a pointer) */
+ *
+ * The cast here is used instead of '(c) >= 0', because some compilers emit
+ * a warning that that test is always true when the parameter is an
+ * unsigned type. khw supposes that it could be written as
+ * && ((c) == '\0' || (c) > 0)
+ * to avoid the message, but the cast will likely avoid extra branches even
+ * with stupid compilers.
+ *
+ * The '| 0' part ensures a compiler error if c is not integer (like e.g.,
+ * a pointer) */
# define isASCII(c) ((WIDEST_UTYPE)((c) | 0) < 128)
#endif
-/* The lower 3 bits in both the ASCII and EBCDIC representations of '0' are 0,
- * and the 8 possible permutations of those bits exactly comprise the 8 octal
- * digits */
-#define isOCTAL_A(c) cBOOL(FITS_IN_8_BITS(c) && (0xF8 & (c)) == '0')
+/* Take the eight possible bit patterns of the lower 3 bits and you get the
+ * lower 3 bits of the 8 octal digits, in both ASCII and EBCDIC, so those bits
+ * can be ignored. If the rest match '0', we have an octal */
+#define isOCTAL_A(c) (((WIDEST_UTYPE)((c) | 0) & ~7) == '0')
#ifdef H_PERL /* If have access to perl.h, lookup in its table */
# define _CC_PRINT 6 /* [:print:] */
# define _CC_ALPHANUMERIC 7 /* [:alnum:] */
# define _CC_GRAPH 8 /* [:graph:] */
-# define _CC_CASED 9 /* [:lower:] and [:upper:] under /i */
+# define _CC_CASED 9 /* [:lower:] or [:upper:] under /i */
#define _FIRST_NON_SWASH_CC 10
/* The character classes above are implemented with swashes. The second group
/* If we don't have perl.h, we are compiling a utility program. Below we
* hard-code various macro definitions that wouldn't otherwise be available
- * to it. Most are coded based on first principals. First some ones common
- * to both ASCII and EBCDIC */
+ * to it. Most are coded based on first principles. These are written to
+ * avoid EBCDIC vs. ASCII #ifdef's as much as possible. */
# define isDIGIT_A(c) ((c) <= '9' && (c) >= '0')
# define isBLANK_A(c) ((c) == ' ' || (c) == '\t')
-# define isSPACE_A(c) (isBLANK_A(c) \
- || (c) == '\n' \
- || (c) == '\r' \
- || (c) == '\v' \
+# define isSPACE_A(c) (isBLANK_A(c) \
+ || (c) == '\n' \
+ || (c) == '\r' \
+ || (c) == '\v' \
|| (c) == '\f')
-# ifdef EBCDIC /* There are gaps between 'i' and 'j'; 'r' and 's'. Same
- for uppercase. This is ordered to exclude most things
- early */
-# define isLOWER_A(c) ((c) >= 'a' && (c) <= 'z' \
- && ((c) <= 'i' \
- || ((c) >= 'j' && (c) <= 'r') \
- || (c) >= 's'))
-# define isUPPER_A(c) ((c) >= 'A' && (c) <= 'Z' \
- && ((c) <= 'I' \
- || ((c) >= 'J' && (c) <= 'R') \
- || (c) >= 'S'))
-# else /* ASCII platform. */
-# define isLOWER_A(c) ((c) >= 'a' && (c) <= 'z')
-# define isUPPER_A(c) ((c) <= 'Z' && (c) >= 'A')
-# endif
-
- /* Some more ASCII, non-ASCII common definitions */
+ /* On EBCDIC, there are gaps between 'i' and 'j'; 'r' and 's'. Same for
+ * uppercase. The tests for those aren't necessary on ASCII, but hurt only
+ * performance (if optimization isn't on), and allow the same code to be
+ * used for both platform types */
+# define isLOWER_A(c) ((c) >= 'a' && (c) <= 'z' \
+ && ( (c) <= 'i' \
+ || ((c) >= 'j' && (c) <= 'r') \
+ || (c) >= 's'))
+# define isUPPER_A(c) ((c) >= 'A' && (c) <= 'Z' \
+ && ( (c) <= 'I' \
+ || ((c) >= 'J' && (c) <= 'R') \
+ || (c) >= 'S'))
# define isALPHA_A(c) (isUPPER_A(c) || isLOWER_A(c))
# define isALPHANUMERIC_A(c) (isALPHA_A(c) || isDIGIT_A(c))
# define isWORDCHAR_A(c) (isALPHANUMERIC_A(c) || (c) == '_')
# define isIDFIRST_A(c) (isALPHA_A(c) || (c) == '_')
-# define isXDIGIT_A(c) (isDIGIT_A(c) \
- || ((c) >= 'a' && (c) <= 'f') \
+# define isXDIGIT_A(c) (isDIGIT_A(c) \
+ || ((c) >= 'a' && (c) <= 'f') \
|| ((c) <= 'F' && (c) >= 'A'))
+# define isPUNCT_A(c) ((c) == '-' || (c) == '!' || (c) == '"' \
+ || (c) == '#' || (c) == '$' || (c) == '%' \
+ || (c) == '&' || (c) == '\'' || (c) == '(' \
+ || (c) == ')' || (c) == '*' || (c) == '+' \
+ || (c) == ',' || (c) == '.' || (c) == '/' \
+ || (c) == ':' || (c) == ';' || (c) == '<' \
+ || (c) == '=' || (c) == '>' || (c) == '?' \
+ || (c) == '@' || (c) == '[' || (c) == '\\' \
+ || (c) == ']' || (c) == '^' || (c) == '_' \
+ || (c) == '`' || (c) == '{' || (c) == '|' \
+ || (c) == '}' || (c) == '~')
+# define isGRAPH_A(c) (isALPHANUMERIC_A(c) || isPUNCT_A(c))
+# define isPRINT_A(c) (isGRAPH_A(c) || (c) == ' ')
# ifdef EBCDIC
-# define isPUNCT_A(c) ((c) == '-' || (c) == '!' || (c) == '"' \
- || (c) == '#' || (c) == '$' || (c) == '%' \
- || (c) == '&' || (c) == '\'' || (c) == '(' \
- || (c) == ')' || (c) == '*' || (c) == '+' \
- || (c) == ',' || (c) == '.' || (c) == '/' \
- || (c) == ':' || (c) == ';' || (c) == '<' \
- || (c) == '=' || (c) == '>' || (c) == '?' \
- || (c) == '@' || (c) == '[' || (c) == '\\' \
- || (c) == ']' || (c) == '^' || (c) == '_' \
- || (c) == '`' || (c) == '{' || (c) == '|' \
- || (c) == '}' || (c) == '~')
-# define isGRAPH_A(c) (isALPHANUMERIC_A(c) || isPUNCT_A(c))
-# define isPRINT_A(c) (isGRAPH_A(c) || (c) == ' ')
-
-# ifdef QUESTION_MARK_CTRL
-# define _isQMC(c) ((c) == QUESTION_MARK_CTRL)
-# else
-# define _isQMC(c) 0
-# endif
-
- /* I (khw) can't think of a way to define all the ASCII controls
- * without resorting to a libc (locale-sensitive) call. But we know
- * that all controls but the question-mark one are in the range 0-0x3f.
- * This makes sure that all the controls that have names are included,
- * and all controls that are also considered ASCII in the locale. This
- * may include more or fewer than what it actually should, but the
- * wrong ones are less-important controls, so likely won't impact
- * things (keep in mind that this is compiled only if perl.h isn't
- * available). The question mark control is included if available */
-# define isCNTRL_A(c) (((c) < 0x40 && isascii(c)) \
- || (c) == '\0' || (c) == '\a' || (c) == '\b' \
- || (c) == '\f' || (c) == '\n' || (c) == '\r' \
- || (c) == '\t' || (c) == '\v' || _isQMC(c))
-
+ /* The below is accurate for the 3 EBCDIC code pages traditionally
+ * supported by perl. The only difference between them in the controls
+ * is the position of \n, and that is represented symbolically below */
+# define isCNTRL_A(c) ((c) == '\0' || (c) == '\a' || (c) == '\b' \
+ || (c) == '\f' || (c) == '\n' || (c) == '\r' \
+ || (c) == '\t' || (c) == '\v' \
+ || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */ \
+ || (c) == 7 /* U+7F DEL */ \
+ || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */ \
+ /* DLE, DC[1-3] */ \
+ || (c) == 0x18 /* U+18 CAN */ \
+ || (c) == 0x19 /* U+19 EOM */ \
+ || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */ \
+ || (c) == 0x26 /* U+17 ETB */ \
+ || (c) == 0x27 /* U+1B ESC */ \
+ || (c) == 0x2D /* U+05 ENQ */ \
+ || (c) == 0x2E /* U+06 ACK */ \
+ || (c) == 0x32 /* U+16 SYN */ \
+ || (c) == 0x37 /* U+04 EOT */ \
+ || (c) == 0x3C /* U+14 DC4 */ \
+ || (c) == 0x3D /* U+15 NAK */ \
+ || (c) == 0x3F)/* U+1A SUB */
# define isASCII(c) (isCNTRL_A(c) || isPRINT_A(c))
-# else /* ASCII platform; things are simpler, and isASCII has already
- been defined */
-# define isGRAPH_A(c) (((c) > ' ' && (c) < 127))
-# define isPRINT_A(c) (isGRAPH_A(c) || (c) == ' ')
-# define isPUNCT_A(c) (isGRAPH_A(c) && (! isALPHANUMERIC_A(c)))
-# define isCNTRL_A(c) (isASCII(c) && (! isPRINT_A(c)))
+# else /* isASCII is already defined for ASCII platforms, so can use that to
+ define isCNTRL */
+# define isCNTRL_A(c) (isASCII(c) && ! isPRINT_A(c))
# endif
/* The _L1 macros may be unnecessary for the utilities; I (khw) added them
# mkdir -p /opt/perl-catamount
# mkdir -p /opt/perl-catamount/include
# mkdir -p /opt/perl-catamount/lib
-# mkdir -p /opt/perl-catamount/lib/perl5/5.25.3
+# mkdir -p /opt/perl-catamount/lib/perl5/5.25.4
# mkdir -p /opt/perl-catamount/bin
# cp *.h /opt/perl-catamount/include
# cp libperl.a /opt/perl-catamount/lib
-# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.25.3
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.25.4
# 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
# of FreeBSD.
d_printf_format_null='undef'
+# As of 10.3-RELEASE FreeBSD. See [perl #128867]
+d_uselocale='undef'
# Debian 4.0 puts ndbm in the -lgdbm_compat library.
libswanted="$libswanted gdbm_compat"
+# malloc wrap works
+case "$usemallocwrap" in
+'') usemallocwrap='define' ;;
+esac
+
+# The system malloc() is about as fast and as frugal as perl's.
+# Since the system malloc() has been the default since at least
+# 5.001, we might as well leave it that way. --AD 10 Jan 2002
+case "$usemymalloc" in
+'') usemymalloc='n' ;;
+esac
+
case "$optimize" in
'') optimize='-O2' ;;
esac
;;
esac
+case "$libc" in
+'')
+# If you have glibc, then report the version for ./myconfig bug reporting.
+# (Configure doesn't need to know the specific version since it just uses
+# gcc to load the library for all tests.)
+# We don't use __GLIBC__ and __GLIBC_MINOR__ because they
+# are insufficiently precise to distinguish things like
+# libc-2.0.6 and libc-2.0.7.
+ for p in $plibpth
+ do
+ for trylib in libc.so.0.3 libc.so
+ do
+ if $test -e $p/$trylib; then
+ libc=`ls -l $p/$trylib | awk '{print $NF}'`
+ if $test "X$libc" != X; then
+ break
+ fi
+ fi
+ done
+ if $test "X$libc" != X; then
+ break
+ fi
+ done
+ ;;
+esac
+
# Flags needed to produce shared libraries.
lddlflags='-shared'
}
#endif
+/* ------------------------------- pp.h ------------------------------- */
+
+PERL_STATIC_INLINE I32
+S_TOPMARK(pTHX)
+{
+ DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
+ "MARK top %p %"IVdf"\n",
+ PL_markstack_ptr,
+ (IV)*PL_markstack_ptr)));
+ return *PL_markstack_ptr;
+}
+
+PERL_STATIC_INLINE I32
+S_POPMARK(pTHX)
+{
+ DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
+ "MARK pop %p %"IVdf"\n",
+ (PL_markstack_ptr-1),
+ (IV)*(PL_markstack_ptr-1))));
+ assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
+ return *PL_markstack_ptr--;
+}
+
/* ----------------------------- regexp.h ----------------------------- */
PERL_STATIC_INLINE struct regexp *
PERLVAR(I, debug, VOL U32) /* flags given to -D switch */
-PERLVARI(I, maxo, int, MAXO) /* maximum number of ops */
+PERLVARI(I, padlist_generation, U32, 1) /* id to identify padlist clones */
PERLVARI(I, runops, runops_proc_t, RUNOPS_DEFAULT)
/* Hook for File::Glob */
PERLVARI(I, globhook, globhook_t, NULL)
-PERLVARI(I, padlist_generation, U32, 1) /* id to identify padlist clones */
-
/* The last unconditional member of the interpreter structure when 5.18.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
unless ($got_text =~ /
package (?:lexsub)?test;
- use strict 'refs', 'subs';
+(?: BEGIN \{\$\{\^WARNING_BITS\} = "[^"]+"\}
+)? use strict 'refs', 'subs';
use feature [^\n]+
- \Q$vars\E\(\) = (.*)
+(?: (?:CORE::)?state sub \w+;
+)? \Q$vars\E\(\) = (.*)
}/s) {
::fail($desc);
::diag("couldn't extract line from boilerplate\n");
MDEREF_SHIFT
);
-$VERSION = '1.37';
+$VERSION = '1.38';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
sub pessimise {
my ($self, $root, $start) = @_;
+ no warnings 'recursion';
# walk tree in root-to-branch order
$self->_pessimise_walk($root);
return class($op) eq "NULL";
}
+
+# Add a CV to the list of subs that still need deparsing.
+
sub todo {
my $self = shift;
my($cv, $is_form, $name) = @_;
push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
}
+
+# Pop the next sub from the todo list and deparse it
+
sub next_todo {
my $self = shift;
my $ent = shift @{$self->{'subs_todo'}};
- my $cv = $ent->[1];
- if (ref $ent->[3]) { # lexical sub
- my @text;
+ my ($seq, $cv, $is_form, $name) = @$ent;
- # At this point, we may not yet have deparsed the hints that allow
- # lexical subroutines to be recognized. So adjust the current
- # hints and deparse them.
- # When lex subs cease being experimental, we should be able to
- # remove this code.
- {
- local $^H = $self->{'hints'};
- local %^H = %{ $self->{'hinthash'} || {} };
- local ${^WARNING_BITS} = $self->{'warnings'};
- feature->import("lexical_subs");
- warnings->unimport("experimental::lexical_subs");
- # Here we depend on the fact that individual features
- # will always set the feature bundle to ‘custom’
- # (== $feature::hint_mask). If we had another specific bundle
- # enabled previously, normalise it.
- if (($self->{'hints'} & $feature::hint_mask)
- != $feature::hint_mask)
- {
- if ($self->{'hinthash'}) {
- delete $self->{'hinthash'}{$_}
- for grep /^feature_/, keys %{$self->{'hinthash'}};
- }
- else { $self->{'hinthash'} = {} }
- $self->{'hinthash'}
- = _features_from_bundle(@$self{'hints','hinthash'});
- }
- push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H,
- $self->{indent_size}, $^H);
- push @text, $self->declare_warnings($self->{'warnings'},
- ${^WARNING_BITS})
- unless ($self->{'warnings'} // 'u')
- eq (${^WARNING_BITS } // 'u');
- $self->{'warnings'} = ${^WARNING_BITS};
- $self->{'hints'} = $^H;
- $self->{'hinthash'} = {%^H};
- }
+ # any 'use strict; package foo' that should come before the sub
+ # declaration to sync with the first COP of the sub
+ my $pragmata = '';
+ if ($cv and !null($cv->START) and is_state($cv->START)) {
+ $pragmata = $self->pragmata($cv->START);
+ }
- # Now emit the sub itself.
- my $padname = $ent->[3];
- my $flags = $padname->FLAGS;
+ if (ref $name) { # lexical sub
+ # emit the sub.
+ my @text;
+ my $flags = $name->FLAGS;
push @text,
- !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW
+ !$cv || $seq <= $name->COP_SEQ_RANGE_LOW
? $self->keyword($flags & SVpad_OUR
? "our"
: $flags & SVpad_STATE
# XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
# doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
# we have a core bug here.
- push @text, "sub " . substr $padname->PVX, 1;
+ push @text, "sub " . substr $name->PVX, 1;
if ($cv) {
# my sub foo { }
push @text, " " . $self->deparse_sub($cv);
# my sub foo;
push @text, ";\n";
}
- return join "", @text;
+ return $pragmata . join "", @text;
}
+
my $gv = $cv->GV;
- my $name = $ent->[3] // $self->gv_name($gv);
- if ($ent->[2]) {
- return $self->keyword("format") . " $name =\n"
- . $self->deparse_format($ent->[1]). "\n";
+ $name //= $self->gv_name($gv);
+ if ($is_form) {
+ return $pragmata . $self->keyword("format") . " $name =\n"
+ . $self->deparse_format($cv). "\n";
} else {
my $use_dec;
if ($name eq "BEGIN") {
$use_dec = $self->begin_is_use($cv);
if (defined ($use_dec) and $self->{'expand'} < 5) {
- return () if 0 == length($use_dec);
+ return $pragmata if 0 == length($use_dec);
+
+ # XXX bit of a hack: Test::More's use_ok() method
+ # builds a fake use statement which deparses as, e.g.
+ # use Net::Ping (@{$args[0];});
+ # As well as being superfluous (the use_ok() is deparsed
+ # too) and ugly, it fails under use strict and otherwise
+ # makes use of a lexical var that's not in scope.
+ # So strip it out.
+ return $pragmata
+ if $use_dec =~ /^use \S+ \(@\{\$args\[0\];}\);/;
+
$use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
}
}
}
}
if ($use_dec) {
- return "$p$l$use_dec";
+ return "$pragmata$p$l$use_dec";
}
if ( $name !~ /::/ and $self->lex_in_scope("&$name")
|| $self->lex_in_scope("&$name", 1) )
} elsif (defined $stash) {
$name =~ s/^\Q$stash\E::(?!\z|.*::)//;
}
- my $ret = "${p}${l}" . $self->keyword("sub") . " $name "
+ my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name "
. $self->deparse_sub($cv);
$self->{'subs_declared'}{$name} = 1;
return $ret;
}
}
+
# Return a "use" declaration for this BEGIN block, if appropriate
sub begin_is_use {
my ($self, $cv) = @_;
sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
}
+
+# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem
+# ops into a subroutine signature. If successful, return the first op
+# following the signature ops plus the signature string; else return the
+# empty list.
+#
+# Normally a bunch of argelem ops will have been generated by the
+# signature parsing, but it's possible that ops have been added manually
+# or altered. In this case we "return ()" and fall back to general
+# deparsing of the individual sigelems as 'my $x = $_[N]' etc.
+#
+# We're only called if the first two ops are nextstate and argcheck.
+
+sub deparse_argops {
+ my ($self, $firstop, $cv) = @_;
+
+ my @sig;
+ my $o = $firstop;
+ return if $o->label; #first nextstate;
+
+ # OP_ARGCHECK
+
+ $o = $o->sibling;
+ my ($params, $opt_params, $slurpy) = $o->aux_list($cv);
+ my $mandatory = $params - $opt_params;
+ my $seen_slurpy = 0;
+ my $last_ix = -1;
+
+ # keep looking for valid nextstate + argelem pairs
+
+ while (1) {
+ # OP_NEXTSTATE
+ $o = $o->sibling;
+ last unless $$o;
+ last unless $o->name =~ /^(next|db)state$/;
+ last if $o->label;
+
+ # OP_ARGELEM
+ my $o2 = $o->sibling;
+ last unless $$o2;
+
+ if ($o2->name eq 'argelem') {
+ my $ix = $o2->string($cv);
+ while (++$last_ix < $ix) {
+ push @sig, $last_ix < $mandatory ? '$' : '$=';
+ }
+ my $var = $self->padname($o2->targ);
+ if ($var =~ /^[@%]/) {
+ return if $seen_slurpy;
+ $seen_slurpy = 1;
+ return if $ix != $params or !$slurpy
+ or substr($var,0,1) ne $slurpy;
+ }
+ else {
+ return if $ix >= $params;
+ }
+ if ($o2->flags & OPf_KIDS) {
+ my $kid = $o2->first;
+ return unless $$kid and $kid->name eq 'argdefelem';
+ my $def = $self->deparse($kid->first, 7);
+ $def = "($def)" if $kid->first->flags & OPf_PARENS;
+ $var .= " = $def";
+ }
+ push @sig, $var;
+ }
+ elsif ($o2->name eq 'null'
+ and ($o2->flags & OPf_KIDS)
+ and $o2->first->name eq 'argdefelem')
+ {
+ # special case - a void context default expression: $ = expr
+
+ my $defop = $o2->first;
+ my $ix = $defop->targ;
+ while (++$last_ix < $ix) {
+ push @sig, $last_ix < $mandatory ? '$' : '$=';
+ }
+ return if $last_ix >= $params
+ or $last_ix < $mandatory;
+ my $def = $self->deparse($defop->first, 7);
+ $def = "($def)" if $defop->first->flags & OPf_PARENS;
+ push @sig, '$ = ' . $def;
+ }
+ else {
+ last;
+ }
+
+ $o = $o2;
+ }
+
+ while (++$last_ix < $params) {
+ push @sig, $last_ix < $mandatory ? '$' : '$=';
+ }
+ push @sig, $slurpy if $slurpy and !$seen_slurpy;
+
+ return ($o, join(', ', @sig));
+}
+
+# Deparse a sub. Returns everything except the 'sub foo',
+# e.g. ($$) : method { ...; }
+# or ($a, $b) : prototype($$) lvalue;
+
sub deparse_sub {
my $self = shift;
my $cv = shift;
- my $proto = "";
+ my @attrs;
+ my $protosig; # prototype or signature (what goes in the (....))
+
Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
local $self->{'curcop'} = $self->{'curcop'};
+
+ my $has_sig = $self->{hinthash}{feature_signatures};
if ($cv->FLAGS & SVf_POK) {
- $proto = "(". $cv->PV . ") ";
+ my $proto = $cv->PV;
+ if ($has_sig) {
+ push @attrs, "prototype($proto)";
+ }
+ else {
+ $protosig = $proto;
+ }
}
if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
- $proto .= ": ";
- $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
- $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
- $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
- $proto .= "const " if $cv->CvFLAGS & CVf_ANONCONST;
+ push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE;
+ push @attrs, "locked" if $cv->CvFLAGS & CVf_LOCKED;
+ push @attrs, "method" if $cv->CvFLAGS & CVf_METHOD;
+ push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST;
}
local($self->{'curcv'}) = $cv;
$self->pessimise($root, $cv->START);
my $lineseq = $root->first;
if ($lineseq->name eq "lineseq") {
- my @ops;
- for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
+ my $firstop = $lineseq->first;
+
+ if ($has_sig) {
+ my $o2;
+ # try to deparse first few ops as a signature if possible
+ if ( $$firstop
+ and $firstop->name =~ /^(next|db)state$/
+ and (($o2 = $firstop->sibling))
+ and $$o2)
+ {
+ if ($o2->name eq 'argcheck') {
+ my ($nexto, $sig) = $self->deparse_argops($firstop, $cv);
+ if (defined $nexto) {
+ $firstop = $nexto;
+ $protosig = $sig;
+ }
+ }
+ }
+ }
+
+ my @ops;
+ for (my $o = $firstop; $$o; $o=$o->sibling) {
push @ops, $o;
}
$body = $self->lineseq(undef, 0, @ops).";";
+ if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) {
+ # this handles void context in
+ # use feature signatures; sub ($=1) {}
+ $body .= "\n()";
+ }
my $scope_en = $self->find_scope_en($lineseq);
if (defined $scope_en) {
my $subs = join"", $self->seq_subs($scope_en);
else {
$body = $self->deparse($root->first, 0);
}
+ $body = "{\n\t$body\n\b}";
}
else {
my $sv = $cv->const_sv;
if ($$sv) {
# uh-oh. inlinable sub... format it differently
- return $proto . "{ " . $self->const($sv, 0) . " }\n";
+ $body = "{ " . $self->const($sv, 0) . " }\n";
} else { # XSUB? (or just a declaration)
- return "$proto;\n";
+ $body = ';'
}
}
- return $proto ."{\n\t$body\n\b}" ."\n";
+ $protosig = defined $protosig ? "($protosig) " : "";
+ my $attrs = '';
+ $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs;
+ return "$protosig$attrs$body\n";
}
sub deparse_format {
return $hh;
}
-# Notice how subs and formats are inserted between statements here;
-# also $[ assignments and pragmas.
-sub pp_nextstate {
+# generate any pragmas, 'package foo' etc needed to synchronise
+# with the given cop
+
+sub pragmata {
my $self = shift;
- my($op, $cx) = @_;
- $self->{'curcop'} = $op;
+ my($op) = @_;
+
my @text;
- push @text, $self->cop_subs($op);
- if (@text) {
- # Special marker to swallow up the semicolon
- push @text, "\cK";
- }
+
my $stash = $op->stashpv;
if ($stash ne $self->{'curstash'}) {
push @text, $self->keyword("package") . " $stash;\n";
$self->{'hinthash'} = $newhh;
}
+ return join("", @text);
+}
+
+
+# Notice how subs and formats are inserted between statements here;
+# also $[ assignments and pragmas.
+sub pp_nextstate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ $self->{'curcop'} = $op;
+
+ my @text;
+
+ my @subs = $self->cop_subs($op);
+ if (@subs) {
+ # Special marker to swallow up the semicolon
+ push @subs, "\cK";
+ }
+ push @text, @subs;
+
+ push @text, $self->pragmata($op);
+
+
# This should go after of any branches that add statements, to
# increase the chances that it refers to the same line it did in
# the original program.
if ($op->first && ($op->first->flags & OPf_KIDS)) {
# arbitrary initial expression, e.g. f(1,2,3)->[...]
- $text .= $self->deparse($op->first, 24);
+ my $expr = $self->deparse($op->first, 24);
+ # stop "exists (expr)->{...}" being interpreted as
+ #"(exists (expr))->{...}"
+ $expr = "+$expr" if $expr =~ /^\(/;
+ $text .= $expr;
}
my @items = $op->aux_list($self->{curcv});
: &pp_padsv) . ')'
}
+
+sub pp_argcheck {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv});
+ my $mandatory = $params - $opt_params;
+ my $check = '';
+
+ $check .= <<EOF if !$slurpy;
+die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $params;
+EOF
+
+ $check .= <<EOF if $mandatory > 0;
+die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory;
+EOF
+
+ my $cond = ($params & 1) ? 'unless' : 'if';
+ $check .= <<EOF if $slurpy eq '%';
+die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $params && ((\@_ - $params) & 1);
+EOF
+
+ $check =~ s/;\n\z//;
+ return $check;
+}
+
+
+sub pp_argelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $var = $self->padname($op->targ);
+ my $ix = $op->string($self->{curcv});
+ my $expr;
+ if ($op->flags & OPf_KIDS) {
+ $expr = $self->deparse($op->first, 7);
+ }
+ elsif ($var =~ /^[@%]/) {
+ $expr = $ix ? "\@_[$ix .. \$#_]" : '@_';
+ }
+ else {
+ $expr = "\$_[$ix]";
+ }
+ return "my $var = $expr";
+}
+
+
+sub pp_argdefelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $ix = $op->targ;
+ my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : ";
+ my $def = $self->deparse($op->first, 7);
+ $def = "($def)" if $op->first->flags & OPf_PARENS;
+ $expr .= $self->deparse($op->first, $cx);
+ return $expr;
+}
+
+
1;
__END__
=item *
Lexical (my) variables declared in scopes external to a subroutine
-appear in code2ref output text as package variables. This is a tricky
+appear in coderef2text output text as package variables. This is a tricky
problem, as perl has no native facility for referring to a lexical variable
defined within a different scope, although L<PadWalker> is a good start.
$regex =~ s/\s+/\\s+/g;
$regex = '^\{\s*' . $regex . '\s*\}$';
- like($deparsed, qr/$regex/, $desc);
+ like($deparsed, qr/$regex/, $desc)
+ or diag "=============================================\n"
+ . "CODE:\n--------\n$input\n--------\n"
+ . "EXPECTED:\n--------\n{\n$expected\n}\n--------\n"
+ . "GOT:\n--------\n$deparsed\n--------\n"
+ . "=============================================\n";
}
}
# CORE::no
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
.qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`;
-like($a, qr/my sub no;\nCORE::no less;/,
+like($a, qr/my sub no;\n.*CORE::no less;/s,
'CORE::no after my sub no');
# CORE::use
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
.qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`;
-like($a, qr/my sub use;\nCORE::use less;/,
+like($a, qr/my sub use;\n.*CORE::use less;/s,
'CORE::use after my sub use');
# CORE::__DATA__
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
.qq`"use feature q|:all|; my sub __DATA__; `
.qq`CORE::__DATA__" 2>&1`;
-like($a, qr/my sub __DATA__;\n.*\nCORE::__DATA__/s,
+like($a, qr/my sub __DATA__;\n.*CORE::__DATA__/s,
'CORE::__DATA__ after my sub __DATA__');
# sub declarations
my sub f {}
print f();
>>>>
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55"}
+BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
my sub f {
- BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
}
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
state sub f {}
print f();
>>>>
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55"}
+BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
state sub f {
- BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
}
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
####
# multideref with leading expression
my $r;
-my $x = ($r // [])->{'foo'}[0];
+my $x = +($r // [])->{'foo'}[0];
####
# multideref with complex middle index
my(%h, $i, $j, $k);
my $x = $h{'foo'}[$i + $j]{$k};
####
+# multideref with trailing non-simple index that initially looks simple
+# (i.e. the constant "3")
+my($r, $i, $j, $k);
+my $x = +($r || {})->{'foo'}[$i + $j]{3 + $k};
+####
# chdir
chdir 'file';
chdir FH;
$_ |.= $_;
$_ &.= $_;
$_ ^.= $_;
+####
+####
+# Should really use 'no warnings "experimental::signatures"',
+# but it doesn't yet deparse correctly.
+# anon subs used because this test framework doesn't deparse named subs
+# in the DATA code snippets.
+#
+# general signature
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $, $b = $glo::bal, $c = $a, $d = 'foo', $e = -37, $f = 0, $g = 1, $h = undef, $i = $a + 1, $j = /foo/, @) {
+ $x++;
+}
+;
+$x++;
+####
+# Signature and prototype
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : prototype($$) {
+ $x++;
+}
+;
+$x++;
+####
+# Signature and prototype and attrs
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : prototype($$) lvalue {
+ $x++;
+}
+;
+$x++;
+####
+# Signature and attrs
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : lvalue method {
+ $x++;
+}
+;
+$x++;
+####
+# named array slurp, null body
+no warnings;
+use feature 'signatures';
+sub (@a) {
+ ;
+}
+;
+####
+# named hash slurp
+no warnings;
+use feature 'signatures';
+sub ($key, %h) {
+ $h{$key};
+}
+;
+####
+# anon hash slurp
+no warnings;
+use feature 'signatures';
+sub ($a, %) {
+ $a;
+}
+;
+####
+# parenthesised default arg
+no warnings;
+use feature 'signatures';
+sub ($a, $b = (/foo/), $c = 1) {
+ $a + $b + $c;
+}
+;
+####
+# parenthesised default arg with TARGMY
+no warnings;
+use feature 'signatures';
+sub ($a, $b = ($a + 1), $c = 1) {
+ $a + $b + $c;
+}
+;
+####
+# empty default
+no warnings;
+use feature 'signatures';
+sub ($a, $=) {
+ $a;
+}
+;
our %bits;
-our $VERSION = "5.025003";
+our $VERSION = "5.025004";
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
bitmax => 7,
bitmask => 255,
},
+ {
+ mask_def => 'OPpARGELEM_MASK',
+ bitmin => 1,
+ bitmax => 2,
+ bitmask => 6,
+ enum => [
+ 0, 'OPpARGELEM_SV', 'SV',
+ 1, 'OPpARGELEM_AV', 'AV',
+ 2, 'OPpARGELEM_HV', 'HV',
+ ],
+ },
{
mask_def => 'OPpDEREF',
bitmin => 4,
@{$bits{accept}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
$bits{aeach}{0} = $bf[0];
-@{$bits{aelem}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
+@{$bits{aelem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
$bits{akeys}{0} = $bf[0];
$bits{anonconst}{0} = $bf[0];
@{$bits{anonhash}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{anonlist}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+$bits{argcheck}{0} = $bf[0];
+$bits{argdefelem}{0} = $bf[0];
+@{$bits{argelem}}{2,1,0} = ($bf[7], $bf[7], $bf[0]);
@{$bits{atan2}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{av2arylen}{0} = $bf[0];
$bits{avalues}{0} = $bf[0];
@{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
$bits{entergiven}{0} = $bf[0];
$bits{enteriter}{3} = 'OPpITER_DEF';
-@{$bits{entersub}}{5,4,0} = ($bf[7], $bf[7], 'OPpENTERSUB_INARGS');
+@{$bits{entersub}}{5,4,0} = ($bf[8], $bf[8], 'OPpENTERSUB_INARGS');
$bits{entertry}{0} = $bf[0];
$bits{enterwhen}{0} = $bf[0];
@{$bits{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{gsockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{gt}}{1,0} = ($bf[1], $bf[1]);
$bits{gv}{5} = 'OPpEARLY_CV';
-@{$bits{helem}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
+@{$bits{helem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
$bits{hex}{0} = $bf[0];
@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]);
$bits{lstat}{0} = $bf[0];
@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
$bits{lvavref}{0} = $bf[0];
-@{$bits{lvref}}{5,4,0} = ($bf[8], $bf[8], $bf[0]);
+@{$bits{lvref}}{5,4,0} = ($bf[9], $bf[9], $bf[0]);
$bits{mapstart}{0} = $bf[0];
$bits{mapwhile}{0} = $bf[0];
$bits{method}{0} = $bf[0];
$bits{ord}{0} = $bf[0];
@{$bits{pack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
-@{$bits{padsv}}{5,4} = ($bf[7], $bf[7]);
+@{$bits{padsv}}{5,4} = ($bf[8], $bf[8]);
@{$bits{pipe_op}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{pop}{0} = $bf[0];
$bits{pos}{0} = $bf[0];
@{$bits{recv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{redo}{0} = $bf[0];
$bits{ref}{0} = $bf[0];
-@{$bits{refassign}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
+@{$bits{refassign}}{5,4,1,0} = ($bf[9], $bf[9], $bf[1], $bf[1]);
$bits{refgen}{0} = $bf[0];
$bits{regcmaybe}{0} = $bf[0];
$bits{regcomp}{0} = $bf[0];
$bits{rmdir}{0} = $bf[0];
$bits{rv2av}{0} = $bf[0];
@{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
-@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[7], $bf[7], 'OPpDONT_INIT_GV', $bf[0]);
+@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[8], $bf[8], 'OPpDONT_INIT_GV', $bf[0]);
$bits{rv2hv}{0} = $bf[0];
-@{$bits{rv2sv}}{5,4,0} = ($bf[7], $bf[7], $bf[0]);
+@{$bits{rv2sv}}{5,4,0} = ($bf[8], $bf[8], $bf[0]);
@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]);
@{$bits{sbit_and}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sbit_or}}{1,0} = ($bf[1], $bf[1]);
OPpARG2_MASK => 3,
OPpARG3_MASK => 7,
OPpARG4_MASK => 15,
+ OPpARGELEM_AV => 2,
+ OPpARGELEM_HV => 4,
+ OPpARGELEM_MASK => 6,
+ OPpARGELEM_SV => 0,
OPpASSIGN_BACKWARDS => 64,
OPpASSIGN_COMMON_AGG => 16,
OPpASSIGN_COMMON_RC1 => 32,
our %labels = (
OPpALLOW_FAKE => 'FAKE',
+ OPpARGELEM_AV => 'AV',
+ OPpARGELEM_HV => 'HV',
+ OPpARGELEM_SV => 'SV',
OPpASSIGN_BACKWARDS => 'BKWARD',
OPpASSIGN_COMMON_AGG => 'COM_AGG',
OPpASSIGN_COMMON_RC1 => 'COM_RC1',
--- /dev/null
+=head1 NAME
+
+Internals - Reserved special namespace for internals related functions
+
+=head1 SYNOPSIS
+
+ $is_ro= Internals::SvREADONLY($x)
+ $refcnt= Internals::SvREFCNT($x)
+
+=head1 DESCRIPTION
+
+The Internals namespace is used by the core Perl development team to
+expose certain low level internals routines for testing and other purposes.
+
+In theory these routines were not and are not intended to be used outside
+of the perl core, and are subject to change and removal at any time.
+
+In practice people have come to depend on these over the years, despite
+being historically undocumented, so we will provide some level of
+forward compatibility for some time. Nevertheless you can assume that any
+routine documented here is experimental or deprecated and you should find
+alternatives to their use.
+
+=head2 FUNCTIONS
+
+=over 4
+
+=item SvREFCNT(THING [, $value])
+
+Historically Perl has been a refcounted language. This means that each
+variable tracks how many things reference it, and when the variable is no
+longer referenced it will automatically free itself. In theory Perl code
+should not have to care about this, and in a future version Perl might
+change to some other strategy, although in practice this is unlikely.
+
+This function allows one to violate the abstraction of variables and get
+or set the refcount of a variable, and in generally is really only useful
+in code that is testing refcount behavior.
+
+*NOTE* You are strongly discouraged from using this function in non-test
+code and especially discouraged from using the set form of this function.
+The results of doing so may result in segmentation faults or other undefined
+behavior.
+
+=item SvREADONLY(THING, [, $value])
+
+Set or get whether a variable is readonly or not. Exactly what the
+readonly flag means depend on the type of the variable affected and the
+version of perl used.
+
+You are strongly discouraged from using this function directly. It is used
+by various core modules, like C<Hash::Util>, and the C<constant> pragma
+to implement higher-level behavior which should be used instead.
+
+See the core implementation for the exact meaning of the readonly flag for
+each internal variable type.
+
+=back
+
+=head1 AUTHOR
+
+Perl core development team.
+
+=head1 SEE ALSO
+
+L<perlguts>
+universal.c
+
+=cut
push @INC, '../lib';
}
-# bug id 20001020.002
+# bug id 20001020.002 (#4480)
# -dlc 20001021
use Tie::Array;
}
{
- # 20001114.001
+ # 20001114.001 (#4690)
no utf8; # naked Latin-1
use feature 'fc', 'postderef';
# =1 adds debugging output; =2 increases the verbosity somewhat
-my $debug = $ENV{PERL_DEBUG_FULL_TEST} // 0;
+our $debug = $ENV{PERL_DEBUG_FULL_TEST} // 0;
# Certain tests have been shown to be problematical for a few locales. Don't
# fail them unless at least this percentage of the tested locales fail.
quoteHighBit => 0,
unctrl => "quote"
);
+
sub debug {
return unless $debug;
my($mess) = join "", '# ', @_;
print STDERR $dumper->stringify($mess,1), "\n";
}
+sub note {
+ local $debug = 1;
+ debug @_;
+}
+
sub debug_more {
return unless $debug > 1;
return debug(@_);
@{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
@{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
@{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
- @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
+ @{$posixes{'cased'}} = grep /[[:upper:][:lower:]]/i, map {chr } 0..255;
# Sieve the uppercase and the lowercase.
@{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
@{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
@{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
- @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
+ @{$posixes{'cased'}} = grep /[[:upper:][:lower:]]/i, map {chr } 0..255;
for (@{$posixes{'word'}}) {
if (/[^\d_]/) { # skip digits and the _
if (uc($_) eq $_) {
debug ":cased: = ", disp_chars(@{$posixes{'cased'}}), "\n";
debug ":alpha: = ", disp_chars(@{$posixes{'alpha'}}), "\n";
debug ":alnum: = ", disp_chars(@{$posixes{'alnum'}}), "\n";
- debug " w = ", disp_chars(@{$posixes{'word'}}), "\n";
+ debug ' \w = ', disp_chars(@{$posixes{'word'}}), "\n";
debug ":graph: = ", disp_chars(@{$posixes{'graph'}}), "\n";
debug ":print: = ", disp_chars(@{$posixes{'print'}}), "\n";
- debug " d = ", disp_chars(@{$posixes{'digit'}}), "\n";
+ debug ' \d = ', disp_chars(@{$posixes{'digit'}}), "\n";
debug ":xdigit: = ", disp_chars(@{$posixes{'xdigit'}}), "\n";
debug ":blank: = ", disp_chars(@{$posixes{'blank'}}), "\n";
- debug " s = ", disp_chars(@{$posixes{'space'}}), "\n";
+ debug ' \s = ', disp_chars(@{$posixes{'space'}}), "\n";
debug ":punct: = ", disp_chars(@{$posixes{'punct'}}), "\n";
debug ":cntrl: = ", disp_chars(@{$posixes{'cntrl'}}), "\n";
debug ":ascii: = ", disp_chars(@{$posixes{'ascii'}}), "\n";
(/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
# effectively is what [:cased:] would be if it existed.
- (/[[:upper:]]/i xor /[[:^upper:]]/i);
+ (/[[:upper:][:lower:]]/i xor /[^[:upper:][:lower:]]/i);
}
else {
push @f, $_ unless (/[[:alpha:]]/ xor /[[:^alpha:]]/) ||
(/[[:upper:]]/ xor /[[:^upper:]]/) ||
(/[[:word:]]/ xor /[[:^word:]]/) ||
(/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
- (/[[:upper:]]/i xor /[[:^upper:]]/i);
+ (/[[:upper:][:lower:]]/i xor /[^[:upper:][:lower:]]/i);
}
}
report_multi_result($Locale, $locales_test_number, \@f);
use locale;
my @sorted_controls = sort @{$posixes{'cntrl'}};
- debug "sorted :cntrl: = ", disp_chars(@sorted_controls), "\n";
+ my $output = "";
+ for my $control (@sorted_controls) {
+ $output .= " " . disp_chars($control);
+ }
+ debug "sorted :cntrl: = $output\n";
++$locales_test_number;
$test_names{$locales_test_number}
foreach my $err (keys %!) {
use Errno;
$! = eval "&Errno::$err"; # Convert to strerror() output
+ my $errnum = 0+$!;
my $strerror = "$!";
if ("$strerror" =~ /\P{ASCII}/) {
$ok14 = utf8::is_utf8($strerror);
no locale;
$ok14_5 = "$!" !~ /\P{ASCII}/;
+ debug( disp_str(
+ "non-ASCII \$! for error $errnum='$strerror'"))
+ if ! $ok14_5;
last;
}
}
use Errno;
$! = eval "&Errno::$err"; # Convert to strerror() output
my $strerror = "$!";
- if ("$strerror" =~ /\P{ASCII}/) {
+ if ($strerror =~ /\P{ASCII}/) {
$ok21 = 0;
+ debug(disp_str("non-ASCII strerror=$strerror"));
last;
}
}
debug "$first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
# Does taking lc separately differ from taking
- # the lc "in-line"? (This was the bug 19990704.002, change #3568.)
+ # the lc "in-line"? (This was the bug 19990704.002 (#965), change #3568.)
# The bug was in the caching of the 'o'-magic.
if (! $is_utf8_locale) {
use locale;
print <<EOW;
#
# If your users are not using these locales you are safe for the moment,
-# but please report this failure first to perlbug\@perl.com using the
+# but please report this failure first to perlbug\@perl.org using the
# perlbug script (as described in the INSTALL file) so that the exact
# details of the failures can be sorted out first and then your operating
# system supplier can be alerted about these anomalies.
--- /dev/null
+use strict;
+use warnings;
+
+# This file tests interactions with locale and threads
+
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
+ require './loc_tools.pl';
+ skip_all("No locales") unless locales_enabled();
+ skip_all_without_config('useithreads');
+ $| = 1;
+}
+
+SKIP: { # perl #127708
+ my @locales = grep { $_ !~ / ^ C \b | POSIX /x } find_locales('LC_MESSAGES',
+ 'non-problematic-only');
+ skip("No valid locale to test with", 1) unless @locales;
+
+ # reset the locale environment
+ local @ENV{'LANG', (grep /^LC_/, keys %ENV)};
+ local $ENV{LC_MESSAGES} = $locales[0];
+
+ # We're going to try with all possible error numbers on this platform
+ my $error_count = keys(%!) + 1;
+
+ print fresh_perl("
+ use threads;
+ use strict;
+ use warnings;
+
+ my \$errnum = 1;
+
+ my \@threads = map +threads->create(sub {
+ sleep 0.1;
+
+ for (1..5_000) {
+ \$errnum = (\$errnum + 1) % $error_count;
+ \$! = \$errnum;
+
+ # no-op to trigger stringification
+ next if \"\$!\" eq \"\";
+ }
+ }), (0..1);
+ \$_->join for splice \@threads;",
+ {}
+ );
+
+ pass("Didn't segfault");
+}
+
+done_testing;
main::ok($x+0 =~ qr/Recurse=ARRAY/);
}
-# BugID 20010422.003
+# BugID 20010422.003 (#6872)
package Foo;
use overload
# Debugger for Perl 5.00x; perl5db.pl patch level:
use vars qw($VERSION $header);
-$VERSION = '1.49_04';
+# bump to X.XX in blead, only use X.XX_XX in maint
+$VERSION = '1.50';
$header = "perl5db.pl version $VERSION";
= $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
# See if we've got the necessary support.
- if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) {
+ if (!eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require PadWalker; PadWalker->VERSION(0.08) }) {
my $Err = $@;
_db_warn(
$Err =~ /locate/
=cut
- if (not $text =~ /::/ and eval { require PadWalker } ) {
+ if (not $text =~ /::/ and eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require PadWalker } ) {
my $level = 1;
while (1) {
my @info = caller($level);
#
# A NOTE ON UNIHAN
#
-# This program can generate tables from the Unihan database. But that db
+# This program can generate tables from the Unihan database. But that DB
# isn't normally available, so it is marked as optional. Prior to version
# 5.2, this database was in a single file, Unihan.txt. In 5.2 the database
# was split into 8 different files, all beginning with the letters 'Unihan'.
# by the code points introduced in the later version. You probably also want
# to use the -annotate option when using this. Run this program on a unicore
# containing the starting release you want to compare. Save that output
-# structrue. Then, switching to a unicore with the ending release, change the
+# structure. Then, switching to a unicore with the ending release, change the
# 0 in the $string_compare_versions definition just below to a string
# containing a SINGLE dotted Unicode release number (e.g. "2.1") corresponding
# to the starting release. This program will then compile, but throw away all
$verbosity = 0;
}
elsif ($arg eq '-w') {
- $write_unchanged_files = 1; # update the files even if havent changed
+ # update the files even if they haven't changed
+ $write_unchanged_files = 1;
}
elsif ($arg eq '-check') {
my $this = shift @ARGV;
qr/ (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x;
my $code_point_re = qr/\b$run_on_code_point_re/;
-# This matches the beginning of the line in the Unicode db files that give the
+# This matches the beginning of the line in the Unicode DB files that give the
# defaults for code points not listed (i.e., missing) in the file. The code
# depends on this ending with a semi-colon, so it can assume it is a valid
# field when the line is split() by semi-colons
# 1) call before the first line is read, for pre processing
# 2) call to adjust each line of the input before the main handler gets
# them. This can be automatically generated, if appropriately simple
-# enough, by specifiying a Properties parameter in the constructor.
+# enough, by specifying a Properties parameter in the constructor.
# 3) call upon EOF before the main handler exits its loop
# 4) call at the end, for post processing
#
# each_line_handler()s. So, if the format of the line is not in the desired
# format for the main handler, these are used to do that adjusting. They can
# be stacked (by enclosing them in an [ anonymous array ] in the constructor,
-# so the $_ output of one is used as the input to the next. The eof handler
+# so the $_ output of one is used as the input to the next. The EOF handler
# is also stackable, but none of the others are, but could easily be changed
# to be so.
#
# not otherwise be processed, and to not raise a warning about not being
# handled. In the constructor call, any value that evaluates to a numeric
# 0 or undef means don't skip. Any other value is a string giving the
- # reason it is being skippped, and this will appear in generated pod.
+ # reason it is being skipped, and this will appear in generated pod.
# However, an empty string reason will suppress the pod entry.
# Internally, calls that evaluate to numeric 0 are changed into undef to
# distinguish them from an empty string call.
# meaningful line of the input file. If present, an appropriate
# each_line_handler() is automatically generated and pushed onto the stack
# of such handlers. This is useful when a file contains multiple
- # proerties per line, but no other special considerations are necessary.
+ # properties per line, but no other special considerations are necessary.
# The special value "<ignored>" means to discard the corresponding input
# field.
# Any @missing lines in the file should also match this syntax; no such
if (! defined $pre_existing) {
- # No name collision, so ok to add the perl synonym.
+ # No name collision, so OK to add the perl synonym.
my $make_re_pod_entry;
my $ok_as_filename;
next;
}
- # Here, there is a name collision, but it still could be ok if
+ # Here, there is a name collision, but it still could be OK if
# the tables match the identical set of code points, in which
# case, we can combine the names. Compare each table's code
# point list to see if they are identical.
Carp::my_carp("Bad news. $property and $ucd_pod{$standard}->{'property'} have unexpected output status and perl-extension combinations. Proceeding anyway.");
}
- # We modifiy the info column of the one being output to
+ # We modify the info column of the one being output to
# indicate the ambiguity. Set $which to point to that one's
# info.
my $which;
push @bad_re_properties, "\n=back\n";
}
- # Similiarly, generate a list of files that we don't use, grouped by the
+ # Similarly, generate a list of files that we don't use, grouped by the
# reasons why (Don't output if the reason is empty). First, create a hash
# whose keys are the reasons, and whose values are anonymous arrays of all
# the files that share that reason.
foreach my $prop_alias ($property->aliases) {
my $prop_alias_name = standardize($prop_alias->name);
- # If no =value, there's just one combination possibe for this
+ # If no =value, there's just one combination possible for this
if (! $value_name) {
# The property may be suppressed, but there may be a proxy
# the children.
make_re_pod_entries($table) if defined $pod_directory;
- # See if the the table matches identical code points with
+ # See if the table matches identical code points with
# something that has already been output. In that case,
# no need to have two files with the same code points in
# them. We use the table's hash() method to store these
# the table. That is, all the property-values given
# by this table. By agreement with Unicode::UCD,
# if the name and full name are identical, and there
- # are no other names, drop the duplcate entry to save
+ # are no other names, drop the duplicate entry to save
# memory.
if (@values_list == 2
&& $values_list[0] eq $values_list[1])
sub generate_tests($$$$$) {
# This used only for making the test script. It generates test cases that
- # are expected to compile successfully in perl. Note that the lhs and
- # rhs are assumed to already be as randomized as the caller wants.
+ # are expected to compile successfully in perl. Note that the LHS and
+ # RHS are assumed to already be as randomized as the caller wants.
my $lhs = shift; # The property: what's to the left of the colon
# or equals separator
my $rhs = shift; # The property value; what's to the right
my $valid_code = shift; # A code point that's known to be in the
- # table given by lhs=rhs; undef if table is
+ # table given by LHS=RHS; undef if table is
# empty
my $invalid_code = shift; # A code point known to not be in the table;
# undef if the table is all code points
# colon or equals separator
my $rhs = shift; # The property value; what's to the right
my $already_in_error = shift; # Boolean; if true it's known that the
- # unmodified lhs and rhs will cause an error.
+ # unmodified LHS and RHS will cause an error.
# This routine should not force another one
# Get the colon or equal
my $separator = generate_separator($lhs);
# Since this is an error only, don't bother to randomly decide whether to
- # put the error on the left or right side; and assume that the rhs is
+ # put the error on the left or right side; and assume that the RHS is
# loosely matched, again for convenience rather than rigor.
$rhs = randomize_loose_name($rhs, 'ERROR') unless $already_in_error;
# for the release it is. To get it to actually mean
# something useful, someone would have to be using an
# earlier Unicode release, and copy it into the directory
- # for that release and recomplile. So far there has been
+ # for that release and recompile. So far there has been
# no demand to do that, so this hasn't been implemented.
Skip => 'Documentation of corrections already '
. 'incorporated into the Unicode data base',
$Tests++;
# A string eval is needed because of the 'no warnings'.
- # Assumes no parens in the regular expression
+ # Assumes no parentheses in the regular expression
my $result = eval "$no_warnings
my \$RegObj = qr($regex);
$string =~ \$RegObj ? 1 : 0";
Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726
# Make sure this gets tested; it was not part of the official test suite at
-# the time this was addded. Note that this is as it would appear in the
+# the time this was added. Note that this is as it would appear in the
# official suite, and gets modified to check for the perl tailoring by
# Test_WB()
Test_WB("$breakable 0020 $breakable 0020 $breakable 0308 $breakable");
#
{
- # bug id 20001009.001
+ # bug id 20001009.001 (#4409)
my ($a, $b);
{
- # bug id 20000730.004
+ # bug id 20000730.004 (#3599)
my $smiley = "\x{263a}";
#ifdef DEBUGGING
if (DEBUG_L_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
- "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%"UVuf", "
- "x_len_longer=%"UVuf","
- " collate multipler=%"UVuf", collate base=%"UVuf"\n",
+ "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%zu, "
+ "x_len_longer=%zu,"
+ " collate multipler=%zu, collate base=%zu\n",
__FILE__, __LINE__,
PL_in_utf8_COLLATE_locale,
x_len_shorter, x_len_longer,
: NULL;
sl_result = my_setlocale(LC_MESSAGES, locale_param);
DEBUG_LOCALE_INIT(LC_MESSAGES, locale_param, sl_result);
- if (! sl_result)
+ if (! sl_result) {
setlocale_failure = TRUE;
}
# endif /* USE_LOCALE_MESSAGES */
/* If this locale has defective collation, skip */
if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: locale's collation is defective\n"));
goto bad;
}
* less-than-perfect results with that character and NUL. This is
* unavoidable unless we replace strxfrm with our own implementation.
*
- * XXX This code may be overkill. khw wrote it before realizing that if
- * you change a NUL into some other character, that that may change the
- * strxfrm results if that character is part of a sequence with other
- * characters for weight calculations. To minimize the chances of this,
- * now the replacement is restricted to another control (likely to be
- * \001). But the full generality has been retained.
- *
* This is one of the few places in the perl core, where we can use
* standard functions like strlen() and strcat(). It's because we're
* looking for NULs. */
char * e = s + len;
char * sans_nuls;
STRLEN cur_min_char_len;
+ int try_non_controls;
/* If we don't know what control character sorts lowest for this
* locale, find it */
if (*PL_strxfrm_min_char == '\0') {
int j;
#ifdef DEBUGGING
- U8 cur_min_cp = 1; /* The code point that sorts lowest, so far */
+ U8 cur_min_cp = 1; /* The code point that sorts lowest, so far */
#endif
char * cur_min_x = NULL; /* And its xfrm, (except it also
includes the collation index
prefixed. */
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
- /* Look through all legal code points (NUL isn't) */
- for (j = 1; j < 256; j++) {
- char * x; /* j's xfrm plus collation index */
- STRLEN x_len; /* length of 'x' */
- STRLEN trial_len = 1;
-
- /* Create a 1 byte string of the current code point, but with
- * room to be 2 bytes */
- char cur_source[] = { (char) j, '\0' , '\0' };
-
- if (PL_in_utf8_COLLATE_locale) {
- if (! isCNTRL_L1(j)) {
- continue;
- }
- /* If needs to be 2 bytes, find them */
- if (! UVCHR_IS_INVARIANT(j)) {
- char * d = cur_source;
- append_utf8_from_native_byte((U8) j, (U8 **) &d);
- trial_len = 2;
+ /* Unlikely, but it may be that no control will work to replace
+ * NUL, in which case we instead look for any character */
+ for (try_non_controls = 0;
+ try_non_controls < 2;
+ try_non_controls++)
+ {
+ /* Look through all legal code points (NUL isn't) */
+ for (j = 1; j < 256; j++) {
+ char * x; /* j's xfrm plus collation index */
+ STRLEN x_len; /* length of 'x' */
+ STRLEN trial_len = 1;
+
+ /* Create a 1 byte string of the current code point, but
+ * with room to be 2 bytes */
+ char cur_source[] = { (char) j, '\0' , '\0' };
+
+ if (PL_in_utf8_COLLATE_locale) {
+ if (! try_non_controls && ! isCNTRL_L1(j)) {
+ continue;
+ }
+
+ /* If needs to be 2 bytes, find them */
+ if (! UVCHR_IS_INVARIANT(j)) {
+ char * d = cur_source;
+ append_utf8_from_native_byte((U8) j, (U8 **) &d);
+ trial_len = 2;
+ }
+ }
+ else if (! try_non_controls && ! isCNTRL_LC(j)) {
+ continue;
}
- }
- else if (! isCNTRL_LC(j)) {
- continue;
- }
- /* Then transform it */
- x = _mem_collxfrm(cur_source, trial_len, &x_len,
- PL_in_utf8_COLLATE_locale);
+ /* Then transform it */
+ x = _mem_collxfrm(cur_source, trial_len, &x_len,
+ PL_in_utf8_COLLATE_locale);
- /* If something went wrong (which it shouldn't), just
- * ignore this code point */
- if ( x_len == 0
- || strlen(x + COLLXFRM_HDR_LEN) < x_len)
- {
- continue;
- }
+ /* Ignore any character that didn't successfully transform
+ * */
+ if (! x) {
+ continue;
+ }
- /* If this character's transformation is lower than
- * the current lowest, this one becomes the lowest */
- if ( cur_min_x == NULL
- || strLT(x + COLLXFRM_HDR_LEN,
- cur_min_x + COLLXFRM_HDR_LEN))
- {
- PL_strxfrm_min_char[0] = cur_source[0];
- PL_strxfrm_min_char[1] = cur_source[1];
- PL_strxfrm_min_char[2] = cur_source[2];
- cur_min_x = x;
+ /* If this character's transformation is lower than
+ * the current lowest, this one becomes the lowest */
+ if ( cur_min_x == NULL
+ || strLT(x + COLLXFRM_HDR_LEN,
+ cur_min_x + COLLXFRM_HDR_LEN))
+ {
+ PL_strxfrm_min_char[0] = cur_source[0];
+ PL_strxfrm_min_char[1] = cur_source[1];
+ PL_strxfrm_min_char[2] = cur_source[2];
+ cur_min_x = x;
#ifdef DEBUGGING
- cur_min_cp = j;
+ cur_min_cp = j;
#endif
+ }
+ else {
+ Safefree(x);
+ }
+ } /* end of loop through all bytes */
+
+ if (cur_min_x) {
+ break;
}
- else {
- Safefree(x);
- }
- } /* end of loop through all bytes */
-
- /* Unlikely, but possible, if there aren't any controls in the
- * locale, arbitrarily use \001 */
- if (cur_min_x == NULL) {
- STRLEN x_len; /* temporary */
- cur_min_x = _mem_collxfrm("\001", 1, &x_len,
- PL_in_utf8_COLLATE_locale);
- /* cur_min_cp was already initialized to 1 */
+
+ /* Unlikely, but possible, if there aren't any controls that
+ * work in the locale, repeat the loop, looking for any
+ * character that works */
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: No control worked. Trying non-controls\n"));
}
- DEBUG_L(PerlIO_printf(Perl_debug_log,
- "_mem_collxfrm: lowest collating non-NUL control in the "
- "0-255 range in locale %s is 0x%02X\n",
- PL_collation_name,
- cur_min_cp));
- if (DEBUG_Lv_TEST) {
- unsigned i;
- PerlIO_printf(Perl_debug_log, "Its xfrm is");
- for (i = 0; i < strlen(cur_min_x + COLLXFRM_HDR_LEN); i ++) {
- PerlIO_printf(Perl_debug_log, " %02x",
- (U8) *(cur_min_x + COLLXFRM_HDR_LEN + i));
- }
- PerlIO_printf(Perl_debug_log, "\n");
+ if (! cur_min_x) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Couldn't find any character to replace"
+ " embedded NULs in locale %s with", PL_collation_name));
+ goto bad;
}
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Replacing embedded NULs in locale %s with "
+ "0x%02X\n", PL_collation_name, cur_min_cp));
+
Safefree(cur_min_x);
}
Newx(sans_nuls, (len * cur_min_char_len) + 1, char);
*sans_nuls = '\0';
-
/* Replace each NUL with the lowest collating control. Loop until have
* exhausted all the NULs */
while (s + s_strlen < e) {
/* If something went wrong (which it shouldn't), just
* ignore this code point */
- if (x_len == 0) {
- Safefree(x);
+ if (! x) {
continue;
}
}
}
+ if (! cur_max_x) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Couldn't find any character to"
+ " replace above-Latin1 chars in locale %s with",
+ PL_collation_name));
+ goto bad;
+ }
+
DEBUG_L(PerlIO_printf(Perl_debug_log,
"_mem_collxfrm: highest 1-byte collating character"
" in locale %s is 0x%02X\n",
PL_collation_name,
PL_strxfrm_max_cp));
- if (DEBUG_Lv_TEST) {
- unsigned i;
- PerlIO_printf(Perl_debug_log, "Its xfrm is ");
- for (i = 0;
- i < strlen(cur_max_x + COLLXFRM_HDR_LEN);
- i++)
- {
- PerlIO_printf(Perl_debug_log, " %02x",
- (U8) cur_max_x[i + COLLXFRM_HDR_LEN]);
- }
- PerlIO_printf(Perl_debug_log, "\n");
- }
Safefree(cur_max_x);
}
+ PL_collxfrm_base
+ (PL_collxfrm_mult * length_in_chars);
Newx(xbuf, xAlloc, char);
- if (UNLIKELY(! xbuf))
+ if (UNLIKELY(! xbuf)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc));
goto bad;
+ }
/* Store the collation id */
*(U32*)xbuf = PL_collation_ix;
/* Then the transformation of the input. We loop until successful, or we
* give up */
for (;;) {
+
*xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
/* If the transformed string occupies less space than we told strxfrm()
* string. */
if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
+ /* Some systems include a trailing NUL in the returned length.
+ * Ignore it, using a loop in case multiple trailing NULs are
+ * returned. */
+ while ( (*xlen) > 0
+ && *(xbuf + COLLXFRM_HDR_LEN + (*xlen) - 1) == '\0')
+ {
+ (*xlen)--;
+ }
+
/* If the first try didn't get it, it means our prediction was low.
* Modify the coefficients so that we predict a larger value in any
* future transformations */
: PL_collxfrm_mult;
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s: %d: initial size of %"UVuf" bytes for a length "
- "%"UVuf" string was insufficient, %"UVuf" needed\n",
+ "%s: %d: initial size of %zu bytes for a length "
+ "%zu string was insufficient, %zu needed\n",
__FILE__, __LINE__,
- (UV) computed_guess, (UV) length_in_chars, (UV) needed));
+ computed_guess, length_in_chars, needed));
/* If slope increased, use it, but discard this result for
* length 1 strings, as we can't be sure that it's a real slope
}
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s: %d: slope is now %"UVuf"; was %"UVuf", base "
- "is now %"UVuf"; was %"UVuf"\n",
+ "%s: %d: slope is now %zu; was %zu, base "
+ "is now %zu; was %zu\n",
__FILE__, __LINE__,
- (UV) PL_collxfrm_mult, (UV) old_m,
- (UV) PL_collxfrm_base, (UV) old_b));
+ PL_collxfrm_mult, old_m,
+ PL_collxfrm_base, old_b));
}
else { /* Slope didn't change, but 'b' did */
const STRLEN new_b = needed
- computed_guess
+ PL_collxfrm_base;
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s: %d: base is now %"UVuf"; was %"UVuf"\n",
+ "%s: %d: base is now %zu; was %zu\n",
__FILE__, __LINE__,
- (UV) new_b, (UV) PL_collxfrm_base));
+ new_b, PL_collxfrm_base));
PL_collxfrm_base = new_b;
}
}
break;
}
- if (UNLIKELY(*xlen >= PERL_INT_MAX))
+ if (UNLIKELY(*xlen >= PERL_INT_MAX)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Needed %zu bytes, max permissible is %u\n",
+ *xlen, PERL_INT_MAX));
goto bad;
+ }
/* A well-behaved strxfrm() returns exactly how much space it needs
- * (not including the trailing NUL) when it fails due to not enough
- * space being provided. Assume that this is the case unless it's been
- * proven otherwise */
+ * (usually not including the trailing NUL) when it fails due to not
+ * enough space being provided. Assume that this is the case unless
+ * it's been proven otherwise */
if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
}
* (Many versions of cygwin fit this. When the buffer size
* isn't sufficient, they return the input size instead of
* how much is needed.)
- * Increase the buffer size by a fixed percentage and try again. */
+ * Increase the buffer size by a fixed percentage and try again.
+ * */
xAlloc += (xAlloc / 4) + 1;
PL_strxfrm_is_behaved = FALSE;
if (DEBUG_Lv_TEST || debug_initialization) {
PerlIO_printf(Perl_debug_log,
"_mem_collxfrm required more space than previously calculated"
- " for locale %s, trying again with new guess=%d+%"UVuf"\n",
+ " for locale %s, trying again with new guess=%d+%zu\n",
PL_collation_name, (int) COLLXFRM_HDR_LEN,
- (UV) xAlloc - COLLXFRM_HDR_LEN);
+ xAlloc - COLLXFRM_HDR_LEN);
}
#endif
}
Renew(xbuf, xAlloc, char);
- if (UNLIKELY(! xbuf))
+ if (UNLIKELY(! xbuf)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: Couldn't realloc %zu bytes\n", xAlloc));
goto bad;
+ }
first_time = FALSE;
}
#ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- unsigned i;
- char * t = s;
- bool prev_was_printable = TRUE;
- bool first_time = TRUE;
- PerlIO_printf(Perl_debug_log,
- "_mem_collxfrm[%d]: returning %"UVuf" for locale %s string '",
- PL_collation_ix, *xlen, PL_collation_name);
- while (t < s + len ) {
- UV cp = (utf8)
- ? utf8_to_uvchr_buf((U8 *) t, s + len, NULL)
- : * (U8 *) t;
- if (isPRINT(cp)) {
- if (! prev_was_printable) {
- PerlIO_printf(Perl_debug_log, " ");
- }
- PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
- prev_was_printable = TRUE;
- }
- else {
- if (! first_time) {
- PerlIO_printf(Perl_debug_log, " ");
- }
- PerlIO_printf(Perl_debug_log, "%02"UVXf"", cp);
- prev_was_printable = FALSE;
- }
- t += (utf8) ? UTF8SKIP(t) : 1;
- first_time = FALSE;
- }
- PerlIO_printf(Perl_debug_log, "'\nIts xfrm is");
+ Size_t i;
+
+ print_collxfrm_input_and_return(s, s + len, xlen, utf8);
+ PerlIO_printf(Perl_debug_log, "Its xfrm is:");
for (i = COLLXFRM_HDR_LEN; i < *xlen + COLLXFRM_HDR_LEN; i++) {
PerlIO_printf(Perl_debug_log, " %02x", (U8) xbuf[i]);
}
*xlen = 0;
#ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%d] returning NULL\n",
- PL_collation_ix);
+ print_collxfrm_input_and_return(s, s + len, NULL, utf8);
}
#endif
return NULL;
}
+#ifdef DEBUGGING
+
+void
+S_print_collxfrm_input_and_return(pTHX_
+ const char * const s,
+ const char * const e,
+ const STRLEN * const xlen,
+ const bool is_utf8)
+{
+ const char * t = s;
+ bool prev_was_printable = TRUE;
+ bool first_time = TRUE;
+
+ PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN;
+
+ PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%d]: returning ",
+ PL_collation_ix);
+ if (xlen) {
+ PerlIO_printf(Perl_debug_log, "%"UVuf"", (UV) *xlen);
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, "NULL");
+ }
+ PerlIO_printf(Perl_debug_log, " for locale '%s', string='",
+ PL_collation_name);
+
+ while (t < e) {
+ UV cp = (is_utf8)
+ ? utf8_to_uvchr_buf((U8 *) t, e, NULL)
+ : * (U8 *) t;
+ if (isPRINT(cp)) {
+ if (! prev_was_printable) {
+ PerlIO_printf(Perl_debug_log, " ");
+ }
+ PerlIO_printf(Perl_debug_log, "%c", (U8) cp);
+ prev_was_printable = TRUE;
+ }
+ else {
+ if (! first_time) {
+ PerlIO_printf(Perl_debug_log, " ");
+ }
+ PerlIO_printf(Perl_debug_log, "%02"UVXf"", cp);
+ prev_was_printable = FALSE;
+ }
+ t += (is_utf8) ? UTF8SKIP(t) : 1;
+ first_time = FALSE;
+ }
+
+ PerlIO_printf(Perl_debug_log, "'\n");
+}
+
+#endif /* #ifdef DEBUGGING */
+
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE
}
char *
-Perl_my_strerror(pTHX_ const int errnum) {
+Perl_my_strerror(pTHX_ const int errnum)
+{
+ /* Returns a mortalized copy of the text of the error message associated
+ * with 'errnum'. It uses the current locale's text unless the platform
+ * doesn't have the LC_MESSAGES category or we are not being called from
+ * within the scope of 'use locale'. In the former case, it uses whatever
+ * strerror returns; in the latter case it uses the text from the C locale.
+ *
+ * The function just calls strerror(), but temporarily switches, if needed,
+ * to the C locale */
+
+ char *errstr;
+
+#ifdef USE_LOCALE_MESSAGES /* If platform doesn't have messages category, we
+ don't do any switching to the C locale; we just
+ use whatever strerror() returns */
+ const bool within_locale_scope = IN_LC(LC_MESSAGES);
+
dVAR;
- /* Uses C locale for the error text unless within scope of 'use locale' for
- * LC_MESSAGES */
+# ifdef USE_THREAD_SAFE_LOCALE
+ locale_t save_locale;
+# else
+ char * save_locale;
+ bool locale_is_C = FALSE;
-#ifdef USE_LOCALE_MESSAGES
- if (! IN_LC(LC_MESSAGES)) {
- char * save_locale;
+ /* We have a critical section to prevent another thread from changing the
+ * locale out from under us (or zapping the buffer returned from
+ * setlocale() ) */
+ LOCALE_LOCK;
- /* We have a critical section to prevent another thread from changing
- * the locale out from under us (or zapping the buffer returned from
- * setlocale() ) */
- LOCALE_LOCK;
+# endif
+
+ if (! within_locale_scope) {
+ errno = 0;
+
+# ifdef USE_THREAD_SAFE_LOCALE /* Use the thread-safe locale functions */
+
+ save_locale = uselocale(PL_C_locale_obj);
+ if (! save_locale) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "uselocale failed, errno=%d\n", errno));
+ }
+
+# else /* Not thread-safe build */
save_locale = setlocale(LC_MESSAGES, NULL);
- if (! isNAME_C_OR_POSIX(save_locale)) {
- char *errstr;
+ if (! save_locale) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "setlocale failed, errno=%d\n", errno));
+ }
+ else {
+ locale_is_C = isNAME_C_OR_POSIX(save_locale);
- /* The next setlocale likely will zap this, so create a copy */
- save_locale = savepv(save_locale);
+ /* Switch to the C locale if not already in it */
+ if (! locale_is_C) {
- setlocale(LC_MESSAGES, "C");
+ /* The setlocale() just below likely will zap 'save_locale', so
+ * create a copy. */
+ save_locale = savepv(save_locale);
+ setlocale(LC_MESSAGES, "C");
+ }
+ }
- /* This points to the static space in Strerror, with all its
- * limitations */
- errstr = Strerror(errnum);
+# endif
- setlocale(LC_MESSAGES, save_locale);
- Safefree(save_locale);
+ } /* end of ! within_locale_scope */
+
+#endif
- LOCALE_UNLOCK;
+ errstr = Strerror(errnum);
+ if (errstr) {
+ errstr = savepv(errstr);
+ SAVEFREEPV(errstr);
+ }
+
+#ifdef USE_LOCALE_MESSAGES
+
+ if (! within_locale_scope) {
+ errno = 0;
- return errstr;
+# ifdef USE_THREAD_SAFE_LOCALE
+
+ if (save_locale && ! uselocale(save_locale)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "uselocale restore failed, errno=%d\n", errno));
}
+ }
- LOCALE_UNLOCK;
+# else
+
+ if (save_locale && ! locale_is_C) {
+ if (! setlocale(LC_MESSAGES, save_locale)) {
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "setlocale restore failed, errno=%d\n", errno));
+ }
+ Safefree(save_locale);
+ }
}
+
+ LOCALE_UNLOCK;
+
+# endif
#endif
- return Strerror(errnum);
+ return errstr;
}
/*
);
}
+unless ( $define{'USE_ITHREADS'}
+ && $define{'HAS_NEWLOCALE'})
+{
+ ++$skip{$_} foreach qw(
+ PL_C_locale_obj
+ );
+}
+
unless ($define{'PERL_IMPLICIT_CONTEXT'}) {
++$skip{$_} foreach qw(
PL_my_cxt_index
$sed 's|\.incl\.c|.h|' .deptmp >.deptmp.vos
mv -f .deptmp.vos .deptmp
fi
- $sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
- >>$mf.new
+ $sed -e 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" \
+ -e 'h; s/mini\(perlmain\)/\1/p; g' \
+ .deptmp >>$mf.new
else
$MAKE hlist || ($echo "Searching for .h files..."; \
$echo *.h | $tr ' ' $trnl | $egrep -v '\*' >.hlist)
SSPUSHUV(SAVEt_LONG);
}
-void
-Perl_save_iv(pTHX_ IV *ivp)
-{
- PERL_ARGS_ASSERT_SAVE_IV;
-
- SSCHECK(3);
- SSPUSHIV(*ivp);
- SSPUSHPTR(ivp);
- SSPUSHUV(SAVEt_IV);
-}
-
void
Perl_save_nogv(pTHX_ GV *gv)
{
{
PERL_ARGS_ASSERT_SV_COPYPV;
- sv_copypv_flags(dsv, ssv, 0);
+ sv_copypv_flags(dsv, ssv, SV_GMAGIC);
}
UV /* Made into a function, so can be deprecated */
* HAS_FEGETROUND
* HAS_FPCLASSIFY
* HAS_FREELOCALE
+ * HAS_GAI_STRERROR
* HAS_GMTIME64
* HAS_ISFINITEL
* HAS_ISINFL
* HAS_STRERROR_L
* HAS_TIMEGM
* HAS_USELOCALE
+ * I_XLOCALE
* I16SIZE
* I64SIZE
* I8SIZE
/* FALLTHROUGH */
case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
+ case OP_ARGDEFELEM: /* Was holding signature index. */
o->op_targ = 0;
break;
default:
break;
+ case OP_ARGCHECK:
+ PerlMemShared_free(cUNOP_AUXo->op_aux);
+ break;
+
case OP_MULTIDEREF:
{
UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
* being spread throughout this file.
*/
-STATIC LOGOP *
-S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
+LOGOP *
+Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
dVAR;
LOGOP *logop;
goto nomod;
}
- /* [20011101.069] File test operators interpret OPf_REF to mean that
+ /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
their argument is a filehandle; thus \stat(".") should not set
it. AMS 20011102 */
if (type == OP_REFGEN &&
expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
}
- rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
+ rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
rcop->op_targ = cv_targ;
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
+ rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
rcop->op_private = 1;
/* establish postfix order */
}
}
- logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
+ logop = alloc_LOGOP(type, first, LINKLIST(other));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
live->op_folded = 1;
return live;
}
- logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
+ logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_next = LINKLIST(falseop);
PERL_ARGS_ASSERT_NEWRANGE;
- range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
+ range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_private = (U8)(1 | (flags >> 8));
PERL_ARGS_ASSERT_NEWGIVWHENOP;
PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
- enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
+ enterop = alloc_LOGOP(enter_opcode, block, NULL);
enterop->op_targ = 0;
enterop->op_private = 0;
op_sibling_splice(o, NULL, -1, NULL);
op_free(o);
- enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
+ enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
/* establish postfix order */
enter->op_next = (OP*)enter;
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
+ gwop = alloc_LOGOP(type, o, LINKLIST(kid));
kid->op_next = (OP*)gwop;
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
&& SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
)
goto bad;
+ /* FALLTHROUGH */
default:
qerror(Perl_mess(aTHX_
"Experimental %s on scalar is now forbidden",
is_last = TRUE;
index_skip = action_count;
action |= MDEREF_FLAG_last;
+ if (index_type != MDEREF_INDEX_none)
+ arg--;
}
if (pass)
/* XXX: We avoid setting op_seq here to prevent later calls
to rpeep() from mistakenly concluding that optimisation
has already occurred. This doesn't fix the real problem,
- though (See 20010220.007). AMS 20010719 */
+ though (See 20010220.007 (#5874)). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
o->op_opt = 0;
/* FALLTHROUGH */
case OP_DORASSIGN:
case OP_RANGE:
case OP_ONCE:
+ case OP_ARGDEFELEM:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
DEFER(cLOGOP->op_other);
XSRETURN(AvFILLp(av)+1);
}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
"entersub",
"leavesub",
"leavesublv",
+ "argcheck",
+ "argelem",
+ "argdefelem",
"caller",
"warn",
"die",
"subroutine entry",
"subroutine exit",
"lvalue subroutine return",
+ "check subroutine arguments",
+ "subroutine argument",
+ "subroutine argument default value",
"caller",
"warn",
"die",
Perl_pp_entersub,
Perl_pp_leavesub,
Perl_pp_leavesublv,
+ Perl_pp_argcheck,
+ Perl_pp_argelem,
+ Perl_pp_argdefelem,
Perl_pp_caller,
Perl_pp_warn,
Perl_pp_die,
Perl_ck_subr, /* entersub */
Perl_ck_null, /* leavesub */
Perl_ck_null, /* leavesublv */
+ Perl_ck_null, /* argcheck */
+ Perl_ck_null, /* argelem */
+ Perl_ck_null, /* argdefelem */
Perl_ck_fun, /* caller */
Perl_ck_fun, /* warn */
Perl_ck_fun, /* die */
0x00002141, /* entersub */
0x00000100, /* leavesub */
0x00000100, /* leavesublv */
+ 0x00000f00, /* argcheck */
+ 0x00000f00, /* argelem */
+ 0x00000300, /* argdefelem */
0x00009b08, /* caller */
0x0000240d, /* warn */
0x0000240d, /* die */
END_EXTERN_C
+#define OPpARGELEM_SV 0x00
#define OPpLVREF_SV 0x00
#define OPpARG1_MASK 0x01
#define OPpCOREARGS_DEREF1 0x01
#define OPpENTERSUB_INARGS 0x01
#define OPpSORT_NUMERIC 0x01
#define OPpTRANS_FROM_UTF 0x01
+#define OPpARGELEM_AV 0x02
#define OPpCONST_NOVER 0x02
#define OPpCOREARGS_DEREF2 0x02
#define OPpEVAL_HAS_HH 0x02
#define OPpSORT_INTEGER 0x02
#define OPpTRANS_TO_UTF 0x02
#define OPpARG2_MASK 0x03
+#define OPpARGELEM_HV 0x04
#define OPpCONST_SHORTCIRCUIT 0x04
#define OPpDONT_INIT_GV 0x04
#define OPpENTERSUB_HASTARG 0x04
#define OPpSLICEWARNING 0x04
#define OPpSORT_REVERSE 0x04
#define OPpTRANS_IDENTICAL 0x04
+#define OPpARGELEM_MASK 0x06
#define OPpARG3_MASK 0x07
#define OPpPADRANGE_COUNTSHIFT 0x07
#define OPpCONST_STRICT 0x08
0, 8, -1,
0, 8, -1,
0, 8, -1,
+ 1, -1, 0, 507, 1, 26, 2, 276, -1,
4, -1, 1, 157, 2, 164, 3, 171, -1,
4, -1, 0, 507, 1, 26, 2, 276, 3, 103, -1,
137, /* entersub */
144, /* leavesub */
144, /* leavesublv */
- 146, /* caller */
+ 0, /* argcheck */
+ 146, /* argelem */
+ 0, /* argdefelem */
+ 148, /* caller */
48, /* warn */
48, /* die */
48, /* reset */
-1, /* lineseq */
- 148, /* nextstate */
- 148, /* dbstate */
+ 150, /* nextstate */
+ 150, /* dbstate */
-1, /* unstack */
-1, /* enter */
- 149, /* leave */
+ 151, /* leave */
-1, /* scope */
- 151, /* enteriter */
- 155, /* iter */
+ 153, /* enteriter */
+ 157, /* iter */
-1, /* enterloop */
- 156, /* leaveloop */
+ 158, /* leaveloop */
-1, /* return */
- 158, /* last */
- 158, /* next */
- 158, /* redo */
- 158, /* dump */
- 158, /* goto */
+ 160, /* last */
+ 160, /* next */
+ 160, /* redo */
+ 160, /* dump */
+ 160, /* goto */
48, /* exit */
0, /* method_named */
0, /* method_super */
0, /* leavewhen */
-1, /* break */
-1, /* continue */
- 160, /* open */
+ 162, /* open */
48, /* close */
48, /* pipe_op */
48, /* fileno */
0, /* getpeername */
0, /* lstat */
0, /* stat */
- 165, /* ftrread */
- 165, /* ftrwrite */
- 165, /* ftrexec */
- 165, /* fteread */
- 165, /* ftewrite */
- 165, /* fteexec */
- 170, /* ftis */
- 170, /* ftsize */
- 170, /* ftmtime */
- 170, /* ftatime */
- 170, /* ftctime */
- 170, /* ftrowned */
- 170, /* fteowned */
- 170, /* ftzero */
- 170, /* ftsock */
- 170, /* ftchr */
- 170, /* ftblk */
- 170, /* ftfile */
- 170, /* ftdir */
- 170, /* ftpipe */
- 170, /* ftsuid */
- 170, /* ftsgid */
- 170, /* ftsvtx */
- 170, /* ftlink */
- 170, /* fttty */
- 170, /* fttext */
- 170, /* ftbinary */
+ 167, /* ftrread */
+ 167, /* ftrwrite */
+ 167, /* ftrexec */
+ 167, /* fteread */
+ 167, /* ftewrite */
+ 167, /* fteexec */
+ 172, /* ftis */
+ 172, /* ftsize */
+ 172, /* ftmtime */
+ 172, /* ftatime */
+ 172, /* ftctime */
+ 172, /* ftrowned */
+ 172, /* fteowned */
+ 172, /* ftzero */
+ 172, /* ftsock */
+ 172, /* ftchr */
+ 172, /* ftblk */
+ 172, /* ftfile */
+ 172, /* ftdir */
+ 172, /* ftpipe */
+ 172, /* ftsuid */
+ 172, /* ftsgid */
+ 172, /* ftsvtx */
+ 172, /* ftlink */
+ 172, /* fttty */
+ 172, /* fttext */
+ 172, /* ftbinary */
77, /* chdir */
77, /* chown */
71, /* chroot */
0, /* rewinddir */
0, /* closedir */
-1, /* fork */
- 174, /* wait */
+ 176, /* wait */
77, /* waitpid */
77, /* system */
77, /* exec */
77, /* kill */
- 174, /* getppid */
+ 176, /* getppid */
77, /* getpgrp */
77, /* setpgrp */
77, /* getpriority */
77, /* setpriority */
- 174, /* time */
+ 176, /* time */
-1, /* tms */
0, /* localtime */
48, /* gmtime */
0, /* require */
0, /* dofile */
-1, /* hintseval */
- 175, /* entereval */
+ 177, /* entereval */
144, /* leaveeval */
0, /* entertry */
-1, /* leavetry */
0, /* lock */
0, /* once */
-1, /* custom */
- 181, /* coreargs */
- 185, /* avhvswitch */
+ 183, /* coreargs */
+ 187, /* avhvswitch */
3, /* runcv */
0, /* fc */
-1, /* padcv */
-1, /* introcv */
-1, /* clonecv */
- 187, /* padrange */
- 189, /* refassign */
- 195, /* lvref */
- 201, /* lvrefslice */
- 202, /* lvavref */
+ 189, /* padrange */
+ 191, /* refassign */
+ 197, /* lvref */
+ 203, /* lvrefslice */
+ 204, /* lvavref */
0, /* anonconst */
};
*/
EXTCONST U16 PL_op_private_bitdefs[] = {
- 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, values, pop, shift, grepstart, grepwhile, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */
+ 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, values, pop, shift, grepstart, grepwhile, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, method, argcheck, argdefelem, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */
0x2b5c, 0x3d59, /* pushmark */
0x00bd, /* wantarray, runcv */
0x03b8, 0x17f0, 0x3e0c, 0x38c8, 0x2f25, /* const */
0x2b5c, 0x3079, /* gvsv */
0x1655, /* gv */
0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, smartmatch, lslice, xor */
- 0x2b5c, 0x3d58, 0x02b7, /* padsv */
+ 0x2b5c, 0x3d58, 0x03d7, /* padsv */
0x2b5c, 0x3d58, 0x2c4c, 0x3a49, /* padav */
0x2b5c, 0x3d58, 0x0534, 0x05d0, 0x2c4c, 0x3a49, /* padhv */
0x3819, /* pushre, match, qr, subst */
- 0x2b5c, 0x19d8, 0x02b6, 0x2c4c, 0x2e48, 0x3e04, 0x0003, /* rv2gv */
- 0x2b5c, 0x3078, 0x02b6, 0x3e04, 0x0003, /* rv2sv */
+ 0x2b5c, 0x19d8, 0x03d6, 0x2c4c, 0x2e48, 0x3e04, 0x0003, /* rv2gv */
+ 0x2b5c, 0x3078, 0x03d6, 0x3e04, 0x0003, /* rv2sv */
0x2c4c, 0x0003, /* av2arylen, pos, akeys, keys */
0x2dbc, 0x0e18, 0x0b74, 0x028c, 0x3fc8, 0x3e04, 0x0003, /* rv2cv */
0x018f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */
0x2c4c, 0x0067, /* vec */
0x2b5c, 0x3078, 0x2c4c, 0x3a48, 0x3e04, 0x0003, /* rv2av */
0x025f, /* aelemfast, aelemfast_lex */
- 0x2b5c, 0x2a58, 0x02b6, 0x2c4c, 0x0067, /* aelem, helem */
+ 0x2b5c, 0x2a58, 0x03d6, 0x2c4c, 0x0067, /* aelem, helem */
0x2b5c, 0x2c4c, 0x3a49, /* aslice, hslice */
0x2c4d, /* kvaslice, kvhslice */
0x2b5c, 0x3998, 0x0003, /* delete */
0x26cc, 0x0003, /* reverse */
0x28f8, 0x0003, /* flip, flop */
0x2b5c, 0x0003, /* cond_expr */
- 0x2b5c, 0x0e18, 0x02b6, 0x028c, 0x3fc8, 0x3e04, 0x2481, /* entersub */
+ 0x2b5c, 0x0e18, 0x03d6, 0x028c, 0x3fc8, 0x3e04, 0x2481, /* entersub */
0x33d8, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
+ 0x02aa, 0x0003, /* argelem */
0x00bc, 0x018f, /* caller */
0x21f5, /* nextstate, dbstate */
0x29fc, 0x33d9, /* leave */
0x2d1c, 0x0018, 0x1144, 0x1061, /* coreargs */
0x2c4c, 0x00c7, /* avhvswitch */
0x2b5c, 0x01fb, /* padrange */
- 0x2b5c, 0x3d58, 0x03d6, 0x284c, 0x1748, 0x0067, /* refassign */
- 0x2b5c, 0x3d58, 0x03d6, 0x284c, 0x1748, 0x0003, /* lvref */
+ 0x2b5c, 0x3d58, 0x04f6, 0x284c, 0x1748, 0x0067, /* refassign */
+ 0x2b5c, 0x3d58, 0x04f6, 0x284c, 0x1748, 0x0003, /* lvref */
0x2b5d, /* lvrefslice */
0x2b5c, 0x3d58, 0x0003, /* lvavref */
/* ENTERSUB */ (OPpENTERSUB_INARGS|OPpHINT_STRICT_REFS|OPpENTERSUB_HASTARG|OPpENTERSUB_AMPER|OPpDEREF|OPpENTERSUB_DB|OPpLVAL_INTRO),
/* LEAVESUB */ (OPpARG1_MASK|OPpREFCOUNTED),
/* LEAVESUBLV */ (OPpARG1_MASK|OPpREFCOUNTED),
+ /* ARGCHECK */ (OPpARG1_MASK),
+ /* ARGELEM */ (OPpARG1_MASK|OPpARGELEM_MASK),
+ /* ARGDEFELEM */ (OPpARG1_MASK),
/* CALLER */ (OPpARG4_MASK|OPpOFFBYONE),
/* WARN */ (OPpARG4_MASK),
/* DIE */ (OPpARG4_MASK),
OP_ENTERSUB = 185,
OP_LEAVESUB = 186,
OP_LEAVESUBLV = 187,
- OP_CALLER = 188,
- OP_WARN = 189,
- OP_DIE = 190,
- OP_RESET = 191,
- OP_LINESEQ = 192,
- OP_NEXTSTATE = 193,
- OP_DBSTATE = 194,
- OP_UNSTACK = 195,
- OP_ENTER = 196,
- OP_LEAVE = 197,
- OP_SCOPE = 198,
- OP_ENTERITER = 199,
- OP_ITER = 200,
- OP_ENTERLOOP = 201,
- OP_LEAVELOOP = 202,
- OP_RETURN = 203,
- OP_LAST = 204,
- OP_NEXT = 205,
- OP_REDO = 206,
- OP_DUMP = 207,
- OP_GOTO = 208,
- OP_EXIT = 209,
- OP_METHOD_NAMED = 210,
- OP_METHOD_SUPER = 211,
- OP_METHOD_REDIR = 212,
- OP_METHOD_REDIR_SUPER = 213,
- OP_ENTERGIVEN = 214,
- OP_LEAVEGIVEN = 215,
- OP_ENTERWHEN = 216,
- OP_LEAVEWHEN = 217,
- OP_BREAK = 218,
- OP_CONTINUE = 219,
- OP_OPEN = 220,
- OP_CLOSE = 221,
- OP_PIPE_OP = 222,
- OP_FILENO = 223,
- OP_UMASK = 224,
- OP_BINMODE = 225,
- OP_TIE = 226,
- OP_UNTIE = 227,
- OP_TIED = 228,
- OP_DBMOPEN = 229,
- OP_DBMCLOSE = 230,
- OP_SSELECT = 231,
- OP_SELECT = 232,
- OP_GETC = 233,
- OP_READ = 234,
- OP_ENTERWRITE = 235,
- OP_LEAVEWRITE = 236,
- OP_PRTF = 237,
- OP_PRINT = 238,
- OP_SAY = 239,
- OP_SYSOPEN = 240,
- OP_SYSSEEK = 241,
- OP_SYSREAD = 242,
- OP_SYSWRITE = 243,
- OP_EOF = 244,
- OP_TELL = 245,
- OP_SEEK = 246,
- OP_TRUNCATE = 247,
- OP_FCNTL = 248,
- OP_IOCTL = 249,
- OP_FLOCK = 250,
- OP_SEND = 251,
- OP_RECV = 252,
- OP_SOCKET = 253,
- OP_SOCKPAIR = 254,
- OP_BIND = 255,
- OP_CONNECT = 256,
- OP_LISTEN = 257,
- OP_ACCEPT = 258,
- OP_SHUTDOWN = 259,
- OP_GSOCKOPT = 260,
- OP_SSOCKOPT = 261,
- OP_GETSOCKNAME = 262,
- OP_GETPEERNAME = 263,
- OP_LSTAT = 264,
- OP_STAT = 265,
- OP_FTRREAD = 266,
- OP_FTRWRITE = 267,
- OP_FTREXEC = 268,
- OP_FTEREAD = 269,
- OP_FTEWRITE = 270,
- OP_FTEEXEC = 271,
- OP_FTIS = 272,
- OP_FTSIZE = 273,
- OP_FTMTIME = 274,
- OP_FTATIME = 275,
- OP_FTCTIME = 276,
- OP_FTROWNED = 277,
- OP_FTEOWNED = 278,
- OP_FTZERO = 279,
- OP_FTSOCK = 280,
- OP_FTCHR = 281,
- OP_FTBLK = 282,
- OP_FTFILE = 283,
- OP_FTDIR = 284,
- OP_FTPIPE = 285,
- OP_FTSUID = 286,
- OP_FTSGID = 287,
- OP_FTSVTX = 288,
- OP_FTLINK = 289,
- OP_FTTTY = 290,
- OP_FTTEXT = 291,
- OP_FTBINARY = 292,
- OP_CHDIR = 293,
- OP_CHOWN = 294,
- OP_CHROOT = 295,
- OP_UNLINK = 296,
- OP_CHMOD = 297,
- OP_UTIME = 298,
- OP_RENAME = 299,
- OP_LINK = 300,
- OP_SYMLINK = 301,
- OP_READLINK = 302,
- OP_MKDIR = 303,
- OP_RMDIR = 304,
- OP_OPEN_DIR = 305,
- OP_READDIR = 306,
- OP_TELLDIR = 307,
- OP_SEEKDIR = 308,
- OP_REWINDDIR = 309,
- OP_CLOSEDIR = 310,
- OP_FORK = 311,
- OP_WAIT = 312,
- OP_WAITPID = 313,
- OP_SYSTEM = 314,
- OP_EXEC = 315,
- OP_KILL = 316,
- OP_GETPPID = 317,
- OP_GETPGRP = 318,
- OP_SETPGRP = 319,
- OP_GETPRIORITY = 320,
- OP_SETPRIORITY = 321,
- OP_TIME = 322,
- OP_TMS = 323,
- OP_LOCALTIME = 324,
- OP_GMTIME = 325,
- OP_ALARM = 326,
- OP_SLEEP = 327,
- OP_SHMGET = 328,
- OP_SHMCTL = 329,
- OP_SHMREAD = 330,
- OP_SHMWRITE = 331,
- OP_MSGGET = 332,
- OP_MSGCTL = 333,
- OP_MSGSND = 334,
- OP_MSGRCV = 335,
- OP_SEMOP = 336,
- OP_SEMGET = 337,
- OP_SEMCTL = 338,
- OP_REQUIRE = 339,
- OP_DOFILE = 340,
- OP_HINTSEVAL = 341,
- OP_ENTEREVAL = 342,
- OP_LEAVEEVAL = 343,
- OP_ENTERTRY = 344,
- OP_LEAVETRY = 345,
- OP_GHBYNAME = 346,
- OP_GHBYADDR = 347,
- OP_GHOSTENT = 348,
- OP_GNBYNAME = 349,
- OP_GNBYADDR = 350,
- OP_GNETENT = 351,
- OP_GPBYNAME = 352,
- OP_GPBYNUMBER = 353,
- OP_GPROTOENT = 354,
- OP_GSBYNAME = 355,
- OP_GSBYPORT = 356,
- OP_GSERVENT = 357,
- OP_SHOSTENT = 358,
- OP_SNETENT = 359,
- OP_SPROTOENT = 360,
- OP_SSERVENT = 361,
- OP_EHOSTENT = 362,
- OP_ENETENT = 363,
- OP_EPROTOENT = 364,
- OP_ESERVENT = 365,
- OP_GPWNAM = 366,
- OP_GPWUID = 367,
- OP_GPWENT = 368,
- OP_SPWENT = 369,
- OP_EPWENT = 370,
- OP_GGRNAM = 371,
- OP_GGRGID = 372,
- OP_GGRENT = 373,
- OP_SGRENT = 374,
- OP_EGRENT = 375,
- OP_GETLOGIN = 376,
- OP_SYSCALL = 377,
- OP_LOCK = 378,
- OP_ONCE = 379,
- OP_CUSTOM = 380,
- OP_COREARGS = 381,
- OP_AVHVSWITCH = 382,
- OP_RUNCV = 383,
- OP_FC = 384,
- OP_PADCV = 385,
- OP_INTROCV = 386,
- OP_CLONECV = 387,
- OP_PADRANGE = 388,
- OP_REFASSIGN = 389,
- OP_LVREF = 390,
- OP_LVREFSLICE = 391,
- OP_LVAVREF = 392,
- OP_ANONCONST = 393,
+ OP_ARGCHECK = 188,
+ OP_ARGELEM = 189,
+ OP_ARGDEFELEM = 190,
+ OP_CALLER = 191,
+ OP_WARN = 192,
+ OP_DIE = 193,
+ OP_RESET = 194,
+ OP_LINESEQ = 195,
+ OP_NEXTSTATE = 196,
+ OP_DBSTATE = 197,
+ OP_UNSTACK = 198,
+ OP_ENTER = 199,
+ OP_LEAVE = 200,
+ OP_SCOPE = 201,
+ OP_ENTERITER = 202,
+ OP_ITER = 203,
+ OP_ENTERLOOP = 204,
+ OP_LEAVELOOP = 205,
+ OP_RETURN = 206,
+ OP_LAST = 207,
+ OP_NEXT = 208,
+ OP_REDO = 209,
+ OP_DUMP = 210,
+ OP_GOTO = 211,
+ OP_EXIT = 212,
+ OP_METHOD_NAMED = 213,
+ OP_METHOD_SUPER = 214,
+ OP_METHOD_REDIR = 215,
+ OP_METHOD_REDIR_SUPER = 216,
+ OP_ENTERGIVEN = 217,
+ OP_LEAVEGIVEN = 218,
+ OP_ENTERWHEN = 219,
+ OP_LEAVEWHEN = 220,
+ OP_BREAK = 221,
+ OP_CONTINUE = 222,
+ OP_OPEN = 223,
+ OP_CLOSE = 224,
+ OP_PIPE_OP = 225,
+ OP_FILENO = 226,
+ OP_UMASK = 227,
+ OP_BINMODE = 228,
+ OP_TIE = 229,
+ OP_UNTIE = 230,
+ OP_TIED = 231,
+ OP_DBMOPEN = 232,
+ OP_DBMCLOSE = 233,
+ OP_SSELECT = 234,
+ OP_SELECT = 235,
+ OP_GETC = 236,
+ OP_READ = 237,
+ OP_ENTERWRITE = 238,
+ OP_LEAVEWRITE = 239,
+ OP_PRTF = 240,
+ OP_PRINT = 241,
+ OP_SAY = 242,
+ OP_SYSOPEN = 243,
+ OP_SYSSEEK = 244,
+ OP_SYSREAD = 245,
+ OP_SYSWRITE = 246,
+ OP_EOF = 247,
+ OP_TELL = 248,
+ OP_SEEK = 249,
+ OP_TRUNCATE = 250,
+ OP_FCNTL = 251,
+ OP_IOCTL = 252,
+ OP_FLOCK = 253,
+ OP_SEND = 254,
+ OP_RECV = 255,
+ OP_SOCKET = 256,
+ OP_SOCKPAIR = 257,
+ OP_BIND = 258,
+ OP_CONNECT = 259,
+ OP_LISTEN = 260,
+ OP_ACCEPT = 261,
+ OP_SHUTDOWN = 262,
+ OP_GSOCKOPT = 263,
+ OP_SSOCKOPT = 264,
+ OP_GETSOCKNAME = 265,
+ OP_GETPEERNAME = 266,
+ OP_LSTAT = 267,
+ OP_STAT = 268,
+ OP_FTRREAD = 269,
+ OP_FTRWRITE = 270,
+ OP_FTREXEC = 271,
+ OP_FTEREAD = 272,
+ OP_FTEWRITE = 273,
+ OP_FTEEXEC = 274,
+ OP_FTIS = 275,
+ OP_FTSIZE = 276,
+ OP_FTMTIME = 277,
+ OP_FTATIME = 278,
+ OP_FTCTIME = 279,
+ OP_FTROWNED = 280,
+ OP_FTEOWNED = 281,
+ OP_FTZERO = 282,
+ OP_FTSOCK = 283,
+ OP_FTCHR = 284,
+ OP_FTBLK = 285,
+ OP_FTFILE = 286,
+ OP_FTDIR = 287,
+ OP_FTPIPE = 288,
+ OP_FTSUID = 289,
+ OP_FTSGID = 290,
+ OP_FTSVTX = 291,
+ OP_FTLINK = 292,
+ OP_FTTTY = 293,
+ OP_FTTEXT = 294,
+ OP_FTBINARY = 295,
+ OP_CHDIR = 296,
+ OP_CHOWN = 297,
+ OP_CHROOT = 298,
+ OP_UNLINK = 299,
+ OP_CHMOD = 300,
+ OP_UTIME = 301,
+ OP_RENAME = 302,
+ OP_LINK = 303,
+ OP_SYMLINK = 304,
+ OP_READLINK = 305,
+ OP_MKDIR = 306,
+ OP_RMDIR = 307,
+ OP_OPEN_DIR = 308,
+ OP_READDIR = 309,
+ OP_TELLDIR = 310,
+ OP_SEEKDIR = 311,
+ OP_REWINDDIR = 312,
+ OP_CLOSEDIR = 313,
+ OP_FORK = 314,
+ OP_WAIT = 315,
+ OP_WAITPID = 316,
+ OP_SYSTEM = 317,
+ OP_EXEC = 318,
+ OP_KILL = 319,
+ OP_GETPPID = 320,
+ OP_GETPGRP = 321,
+ OP_SETPGRP = 322,
+ OP_GETPRIORITY = 323,
+ OP_SETPRIORITY = 324,
+ OP_TIME = 325,
+ OP_TMS = 326,
+ OP_LOCALTIME = 327,
+ OP_GMTIME = 328,
+ OP_ALARM = 329,
+ OP_SLEEP = 330,
+ OP_SHMGET = 331,
+ OP_SHMCTL = 332,
+ OP_SHMREAD = 333,
+ OP_SHMWRITE = 334,
+ OP_MSGGET = 335,
+ OP_MSGCTL = 336,
+ OP_MSGSND = 337,
+ OP_MSGRCV = 338,
+ OP_SEMOP = 339,
+ OP_SEMGET = 340,
+ OP_SEMCTL = 341,
+ OP_REQUIRE = 342,
+ OP_DOFILE = 343,
+ OP_HINTSEVAL = 344,
+ OP_ENTEREVAL = 345,
+ OP_LEAVEEVAL = 346,
+ OP_ENTERTRY = 347,
+ OP_LEAVETRY = 348,
+ OP_GHBYNAME = 349,
+ OP_GHBYADDR = 350,
+ OP_GHOSTENT = 351,
+ OP_GNBYNAME = 352,
+ OP_GNBYADDR = 353,
+ OP_GNETENT = 354,
+ OP_GPBYNAME = 355,
+ OP_GPBYNUMBER = 356,
+ OP_GPROTOENT = 357,
+ OP_GSBYNAME = 358,
+ OP_GSBYPORT = 359,
+ OP_GSERVENT = 360,
+ OP_SHOSTENT = 361,
+ OP_SNETENT = 362,
+ OP_SPROTOENT = 363,
+ OP_SSERVENT = 364,
+ OP_EHOSTENT = 365,
+ OP_ENETENT = 366,
+ OP_EPROTOENT = 367,
+ OP_ESERVENT = 368,
+ OP_GPWNAM = 369,
+ OP_GPWUID = 370,
+ OP_GPWENT = 371,
+ OP_SPWENT = 372,
+ OP_EPWENT = 373,
+ OP_GGRNAM = 374,
+ OP_GGRGID = 375,
+ OP_GGRENT = 376,
+ OP_SGRENT = 377,
+ OP_EGRENT = 378,
+ OP_GETLOGIN = 379,
+ OP_SYSCALL = 380,
+ OP_LOCK = 381,
+ OP_ONCE = 382,
+ OP_CUSTOM = 383,
+ OP_COREARGS = 384,
+ OP_AVHVSWITCH = 385,
+ OP_RUNCV = 386,
+ OP_FC = 387,
+ OP_PADCV = 388,
+ OP_INTROCV = 389,
+ OP_CLONECV = 390,
+ OP_PADRANGE = 391,
+ OP_REFASSIGN = 392,
+ OP_LVREF = 393,
+ OP_LVREFSLICE = 394,
+ OP_LVAVREF = 395,
+ OP_ANONCONST = 396,
OP_max
} opcode;
-#define MAXO 394
+#define MAXO 397
#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because
/* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"%s\" %s %"PNf" masks earlier declaration in same %s",
- (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
+ ( is_our ? "our" :
+ PL_parser->in_my == KEY_my ? "my" :
+ PL_parser->in_my == KEY_sigvar ? "my" :
+ "state" ),
*PadnamePV(sv) == '&' ? "subroutine" : "variable",
PNfARG(sv),
(COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
U8 lex_defer; /* state after determined token */
U8 lex_dojoin; /* doing an array interpolation
1 = @{...} 2 = ->@ */
- U8 lex_expect; /* UNUSED */
U8 expect; /* how to interpret ambiguous tokens */
+ bool preambled;
I32 lex_formbrack; /* bracket count at outer format level */
OP *lex_inpat; /* in pattern $) and $| are special */
OP *lex_op; /* extra info to pass back on op */
SV *lex_stuff; /* runtime pattern from m// or s/// */
I32 multi_start; /* 1st line of multi-line string */
I32 multi_end; /* last line of multi-line string */
- char multi_open; /* delimiter of said string */
- char multi_close; /* delimiter of said string */
- bool preambled;
+ UV multi_open; /* delimiter of said string */
+ UV multi_close; /* delimiter of said string */
bool lex_re_reparsing; /* we're doing G_RE_REPARSING */
+ U8 lex_super_state;/* lexer state to save */
+ U16 lex_sub_inwhat; /* "lex_inwhat" to use in sublex_push */
I32 lex_allbrackets;/* (), [], {}, ?: bracket count */
- SUBLEXINFO sublex_info;
+ OP *lex_sub_op; /* current op in y/// or pattern */
+ SV *lex_sub_repl; /* repl of s/// used in sublex_push */
LEXSHARED *lex_shared;
SV *linestr; /* current chunk of src text */
char *bufptr; /* carries the cursor (current parsing
HV *in_my_stash; /* declared class of this "my" declaration */
PerlIO *rsfp; /* current source file pointer */
AV *rsfp_filters; /* holds chain of active source filters */
- U8 form_lex_state; /* remember lex_state when parsing fmt */
YYSTYPE nextval[5]; /* value of next token, if any */
I32 nexttype[5]; /* type of next token */
- U32 nexttoke;
-
+ U8 nexttoke;
+ U8 form_lex_state; /* remember lex_state when parsing fmt */
+ U8 lex_fakeeof; /* precedence at which to fake EOF */
+ U8 lex_flags;
COP *saved_curcop; /* the previous PL_curcop */
char tokenbuf[256];
line_t herelines; /* number of lines in here-doc */
line_t preambling; /* line # when processing $ENV{PERL5DB} */
- U8 lex_fakeeof; /* precedence at which to fake EOF */
- U8 lex_flags;
+
+ /* these are valid while parsing a subroutine signature */
+ IV sig_elems; /* number of signature elements seen so far */
+ IV sig_optelems; /* number of optional signature elems seen */
+ char sig_slurpy; /* the sigil of the slurpy var (or null) */
+
PERL_BITFIELD16 in_pod:1; /* lexer is within a =pod section */
PERL_BITFIELD16 filtered:1; /* source filters in evalbytes */
PERL_BITFIELD16 saw_infix_sigil:1; /* saw & or * or % operator */
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 25 /* epoch */
-#define PERL_SUBVERSION 3 /* generation */
+#define PERL_SUBVERSION 4 /* generation */
/* The following numbers describe the earliest compatible version of
Perl ("compatibility" here being defined as sufficient binary/API
*/
#define PERL_API_REVISION 5
#define PERL_API_VERSION 25
-#define PERL_API_SUBVERSION 3
+#define PERL_API_SUBVERSION 4
/*
XXX Note: The selection of non-default Configure options, such
as -Duselonglong may invalidate these settings. Currently, Configure
PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
+#ifdef USE_THREAD_SAFE_LOCALE
+ PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
+#endif
ENTER;
}
PerlIO *stdo = PerlIO_stdout();
if (*stdo && PerlIO_flush(stdo)) {
PerlIO_restore_errno(stdo);
- PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s",
- Strerror(errno));
+ if (errno)
+ PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s",
+ Strerror(errno));
if (!STATUS_UNIX)
STATUS_ALL_FAILURE;
}
(void)POPMARK;
old_cxix = cxstack_ix;
create_eval_scope(NULL, flags|G_FAKINGEVAL);
- (void)INCMARK;
+ INCMARK;
JMPENV_PUSH(ret);
s--;
}
PL_rs = newSVpvs("");
- SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
- tmps = (U8*)SvPVX(PL_rs);
+ tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
uvchr_to_utf8(tmps, rschar);
SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
SvUTF8_on(PL_rs);
# include <locale.h>
#endif
+#ifdef I_XLOCALE
+# include <xlocale.h>
+#endif
+
#if !defined(NO_LOCALE) && defined(HAS_SETLOCALE)
# define USE_LOCALE
# define HAS_SKIP_LOCALE_INIT /* Solely for XS code to test for this
# define Perl_isinf(x) isinfq(x)
# define Perl_isnan(x) isnanq(x)
# define Perl_isfinite(x) !(isnanq(x) || isinfq(x))
+# define Perl_fp_class(x) ((x) == 0.0Q ? 0 : isinfq(x) ? 3 : isnanq(x) ? 4 : PERL_ABS(x) < FLT128_MIN ? 2 : 1)
+# define Perl_fp_class_inf(x) (Perl_fp_class(x) == 3)
+# define Perl_fp_class_nan(x) (Perl_fp_class(x) == 4)
+# define Perl_fp_class_norm(x) (Perl_fp_class(x) == 1)
+# define Perl_fp_class_denorm(x) (Perl_fp_class(x) == 2)
+# define Perl_fp_class_zero(x) (Perl_fp_class(x) == 0)
#else
# define NV_DIG DBL_DIG
# ifdef DBL_MANT_DIG
#else
union any {
void* any_ptr;
+ SV* any_sv;
+ SV** any_svp;
+ GV* any_gv;
+ AV* any_av;
+ HV* any_hv;
+ OP* any_op;
+ char* any_pv;
+ char** any_pvp;
I32 any_i32;
U32 any_u32;
IV any_iv;
#undef _XPVMG_HEAD
#undef _XPVCV_COMMON
-typedef struct _sublex_info SUBLEXINFO;
-struct _sublex_info {
- U8 super_state; /* lexer state to save */
- U16 sub_inwhat; /* "lex_inwhat" to use */
- OP *sub_op; /* "lex_op" to use */
- SV *repl; /* replacement of s/// or y/// */
-};
-
#include "parser.h"
typedef struct magic_state MGS; /* struct magic_state defined in mg.c */
#endif /* !PERL_CORE */
#define PL_hints PL_compiling.cop_hints
+#define PL_maxo MAXO
END_EXTERN_C
/* update exp_name[] in toke.c if adding to this enum */
} expectation;
+#define KEY_sigvar 0xFFFF /* fake keyword representing a signature var */
+
/* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer
special and there is no need for HINT_PRIVATE_MASK for COPs
However, bitops store HINT_INTEGER in their op_private.
/* These locale things are all subject to change */
# define LOCALE_INIT MUTEX_INIT(&PL_locale_mutex)
-# define LOCALE_TERM MUTEX_DESTROY(&PL_locale_mutex)
+
+# ifdef USE_THREAD_SAFE_LOCALE
+# define LOCALE_TERM \
+ STMT_START { \
+ MUTEX_DESTROY(&PL_locale_mutex); \
+ if (PL_C_locale_obj) { \
+ /* Make sure we aren't using the locale \
+ * space we are about to free */ \
+ uselocale(LC_GLOBAL_LOCALE); \
+ freelocale(PL_C_locale_obj); \
+ PL_C_locale_obj = (locale_t) NULL; \
+ } \
+ } STMT_END
+ }
+# else
+# define LOCALE_TERM MUTEX_DESTROY(&PL_locale_mutex)
+# endif
# define LOCALE_LOCK MUTEX_LOCK(&PL_locale_mutex)
# define LOCALE_UNLOCK MUTEX_UNLOCK(&PL_locale_mutex)
# endif /* PERL_CORE or PERL_IN_XSUB_RE */
+#if defined(USE_ITHREADS) \
+ && defined(HAS_NEWLOCALE) \
+ && defined(LC_ALL_MASK) \
+ && defined(HAS_FREELOCALE) \
+ && defined(HAS_USELOCALE) \
+ && ! defined(NO_THREAD_SAFE_USELOCALE)
+
+ /* The code is written for simplicity to assume that any platform advanced
+ * enough to have the Posix 2008 locale functions has LC_ALL. The test
+ * above makes sure that assumption is valid */
+
+# define USE_THREAD_SAFE_LOCALE
+#endif
+
#else /* No locale usage */
# define LOCALE_INIT
# define LOCALE_TERM
/* The VAX fp formats are neither consistently little-endian nor
* big-endian, and neither are they really IEEE-mixed endian like
* the mixed-endian ARM IEEE formats (with swapped bytes).
- * Ultimately, the VAX format ultimately came from the PDP.
+ * Ultimately, the VAX format came from the PDP-11.
*
* The ordering of the parts in VAX floats is quite vexing.
* In the below the fraction_n are the mantissa bits.
* (somebody at HP should be fired for the URLs)
*
* F fraction_2:16 sign:1 exp:8 fraction_1:7
- * (exponent bias 128)
+ * (exponent bias 128, hidden first one-bit)
*
* D fraction_2:16 sign:1 exp:8 fraction_1:7
* fraction_4:16 fraction_3:16
- * (exponent bias 128)
+ * (exponent bias 128, hidden first one-bit)
*
* G fraction_2:16 sign:1 exp:11 fraction_1:4
* fraction_4:16 fraction_3:16
- * (exponent bias 1024)
+ * (exponent bias 1024, hidden first one-bit)
*
* H fraction_1:16 sign:1 exp:15
* fraction_3:16 fraction_2:16
* fraction_5:16 fraction_4:16
* fraction_7:16 fraction_6:16
- * (exponent bias 16384)
+ * (exponent bias 16384, hidden first one-bit)
+ * (available only on VAX, and only on Fortran?)
+ *
+ * The formats S, T and X are available on the Alpha (and Itanium,
+ * also known as I64/IA64) and are equivalent with the IEEE-754 formats
+ * binary32, binary64, and binary128 (commonly: float, double, long double).
+ *
+ * S sign:1 exp:8 mantissa:23
+ * (exponent bias 127, hidden first one-bit)
+ *
+ * T sign:1 exp:11 mantissa:52
+ * (exponent bias 1022, hidden first one-bit)
+ *
+ * X sign:1 exp:15 mantissa:112
+ * (exponent bias 16382, hidden first one-bit)
*
- * The formats T and X are available on the Alpha (and IA64?)
- * and are equivalent with the IEEE 754 64 and 128 bit formats.
*/
#ifdef DOUBLE_IS_VAX_FLOAT
#ifdef DOUBLE_IS_IEEE_FORMAT
/* All the basic IEEE formats have the implicit bit,
- * except for the 80-bit extended formats, which will undef this. */
+ * except for the x86 80-bit extended formats, which will undef this.
+ * Also note that the IEEE 754 subnormals (formerly known as denormals)
+ * do not have the implicit bit of one. */
# define NV_IMPLICIT_BIT
#endif
# define LONGDOUBLE_X86_80_BIT
# ifdef USE_LONG_DOUBLE
# undef NV_IMPLICIT_BIT
+# define NV_X86_80_BIT
# endif
# endif
# define LONGDOUBLE_DOUBLEDOUBLE
# endif
+# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_VAX_H_FLOAT
+# define LONGDOUBLE_VAX_ENDIAN
+# endif
+
#endif /* LONG_DOUBLEKIND */
#ifdef USE_QUADMATH /* assume quadmath endianness == native double endianness */
# ifdef LONGDOUBLE_MIX_ENDIAN
# define NV_MIX_ENDIAN
# endif
+# ifdef LONGDOUBLE_VAX_ENDIAN
+# define NV_VAX_ENDIAN
+# endif
#endif
#ifdef DOUBLE_IS_IEEE_FORMAT
#else /* !PERL_CORE */
+#undef PL_C_locale_obj
+#define PL_C_locale_obj (*Perl_GC_locale_obj_ptr(NULL))
#undef PL_appctx
#define PL_appctx (*Perl_Gappctx_ptr(NULL))
#undef PL_check
{
va_list ap;
dSYS;
- va_start(ap, fmt);
if (!DEBUG_i_TEST)
return;
+ va_start(ap, fmt);
+
if (!PL_perlio_debug_fd) {
if (!TAINTING_get &&
PerlProc_getuid() == PerlProc_geteuid() &&
PERLVAR(G, hints_mutex, perl_mutex) /* Mutex for refcounted he refcounting */
PERLVAR(G, locale_mutex, perl_mutex) /* Mutex for setlocale() changing */
+# ifdef HAS_NEWLOCALE
+PERLVAR(G, C_locale_obj, locale_t)
+# endif
+
#endif
#ifdef DEBUGGING
*/
case 2:
-#line 115 "perly.y" /* yacc.c:1646 */
+#line 118 "perly.y" /* yacc.c:1646 */
{
parser->expect = XSTATE;
}
break;
case 3:
-#line 119 "perly.y" /* yacc.c:1646 */
+#line 122 "perly.y" /* yacc.c:1646 */
{
newPROG(block_end((ps[-1].val.ival),(ps[0].val.opval)));
PL_compiling.cop_seq = 0;
break;
case 4:
-#line 125 "perly.y" /* yacc.c:1646 */
+#line 128 "perly.y" /* yacc.c:1646 */
{
parser->expect = XTERM;
}
break;
case 5:
-#line 129 "perly.y" /* yacc.c:1646 */
+#line 132 "perly.y" /* yacc.c:1646 */
{
PL_eval_root = (ps[0].val.opval);
(yyval.ival) = 0;
break;
case 6:
-#line 134 "perly.y" /* yacc.c:1646 */
+#line 137 "perly.y" /* yacc.c:1646 */
{
parser->expect = XBLOCK;
}
break;
case 7:
-#line 138 "perly.y" /* yacc.c:1646 */
+#line 141 "perly.y" /* yacc.c:1646 */
{
PL_pad_reset_pending = TRUE;
PL_eval_root = (ps[0].val.opval);
break;
case 8:
-#line 146 "perly.y" /* yacc.c:1646 */
+#line 149 "perly.y" /* yacc.c:1646 */
{
parser->expect = XSTATE;
}
break;
case 9:
-#line 150 "perly.y" /* yacc.c:1646 */
+#line 153 "perly.y" /* yacc.c:1646 */
{
PL_pad_reset_pending = TRUE;
PL_eval_root = (ps[0].val.opval);
break;
case 10:
-#line 158 "perly.y" /* yacc.c:1646 */
+#line 161 "perly.y" /* yacc.c:1646 */
{
parser->expect = XSTATE;
}
break;
case 11:
-#line 162 "perly.y" /* yacc.c:1646 */
+#line 165 "perly.y" /* yacc.c:1646 */
{
PL_pad_reset_pending = TRUE;
PL_eval_root = (ps[0].val.opval);
break;
case 12:
-#line 170 "perly.y" /* yacc.c:1646 */
+#line 173 "perly.y" /* yacc.c:1646 */
{
parser->expect = XSTATE;
}
break;
case 13:
-#line 174 "perly.y" /* yacc.c:1646 */
+#line 177 "perly.y" /* yacc.c:1646 */
{
PL_eval_root = (ps[0].val.opval);
(yyval.ival) = 0;
break;
case 14:
-#line 182 "perly.y" /* yacc.c:1646 */
+#line 185 "perly.y" /* yacc.c:1646 */
{ if (parser->copline > (line_t)(ps[-3].val.ival))
parser->copline = (line_t)(ps[-3].val.ival);
(yyval.opval) = block_end((ps[-2].val.ival), (ps[-1].val.opval));
break;
case 15:
-#line 190 "perly.y" /* yacc.c:1646 */
+#line 193 "perly.y" /* yacc.c:1646 */
{ if (parser->copline > (line_t)(ps[-6].val.ival))
parser->copline = (line_t)(ps[-6].val.ival);
(yyval.opval) = block_end((ps[-5].val.ival), (ps[-2].val.opval));
break;
case 16:
-#line 197 "perly.y" /* yacc.c:1646 */
+#line 200 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = block_start(TRUE);
parser->parsed_sub = 0; }
break;
case 17:
-#line 202 "perly.y" /* yacc.c:1646 */
+#line 205 "perly.y" /* yacc.c:1646 */
{ if (parser->copline > (line_t)(ps[-3].val.ival))
parser->copline = (line_t)(ps[-3].val.ival);
(yyval.opval) = block_end((ps[-2].val.ival), (ps[-1].val.opval));
break;
case 18:
-#line 209 "perly.y" /* yacc.c:1646 */
+#line 212 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = block_start(FALSE);
parser->parsed_sub = 0; }
break;
case 19:
-#line 215 "perly.y" /* yacc.c:1646 */
+#line 218 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 20:
-#line 217 "perly.y" /* yacc.c:1646 */
+#line 220 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-1].val.opval), (ps[0].val.opval));
PL_pad_reset_pending = TRUE;
if ((ps[-1].val.opval) && (ps[0].val.opval))
break;
case 21:
-#line 226 "perly.y" /* yacc.c:1646 */
+#line 229 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 22:
-#line 228 "perly.y" /* yacc.c:1646 */
+#line 231 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-1].val.opval), (ps[0].val.opval));
PL_pad_reset_pending = TRUE;
if ((ps[-1].val.opval) && (ps[0].val.opval))
break;
case 23:
-#line 237 "perly.y" /* yacc.c:1646 */
+#line 240 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = (ps[0].val.opval) ? newSTATEOP(0, NULL, (ps[0].val.opval)) : NULL;
}
break;
case 24:
-#line 241 "perly.y" /* yacc.c:1646 */
+#line 244 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 25:
-#line 245 "perly.y" /* yacc.c:1646 */
+#line 248 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[-1].val.pval)[strlen((ps[-1].val.pval))+1], (ps[-1].val.pval), (ps[0].val.opval));
}
break;
case 26:
-#line 249 "perly.y" /* yacc.c:1646 */
+#line 252 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[-1].val.pval)[strlen((ps[-1].val.pval))+1], (ps[-1].val.pval), (ps[0].val.opval));
}
break;
case 27:
-#line 256 "perly.y" /* yacc.c:1646 */
+#line 259 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 28:
-#line 258 "perly.y" /* yacc.c:1646 */
+#line 261 "perly.y" /* yacc.c:1646 */
{
CV *fmtcv = PL_compcv;
newFORM((ps[-2].val.ival), (ps[-1].val.opval), (ps[0].val.opval));
break;
case 29:
-#line 268 "perly.y" /* yacc.c:1646 */
+#line 271 "perly.y" /* yacc.c:1646 */
{
if ((ps[-1].val.opval)->op_type == OP_CONST) {
const char *const name =
break;
case 30:
-#line 290 "perly.y" /* yacc.c:1646 */
+#line 293 "perly.y" /* yacc.c:1646 */
{
SvREFCNT_inc_simple_void(PL_compcv);
(ps[-5].val.opval)->op_type == OP_CONST
break;
case 31:
-#line 301 "perly.y" /* yacc.c:1646 */
+#line 304 "perly.y" /* yacc.c:1646 */
{
if ((ps[-1].val.opval)->op_type == OP_CONST) {
const char *const name =
break;
case 32:
-#line 323 "perly.y" /* yacc.c:1646 */
+#line 326 "perly.y" /* yacc.c:1646 */
{
OP *body;
if (parser->copline > (line_t)(ps[-2].val.ival))
break;
case 33:
-#line 340 "perly.y" /* yacc.c:1646 */
+#line 343 "perly.y" /* yacc.c:1646 */
{
package((ps[-1].val.opval));
if ((ps[-2].val.opval))
break;
case 34:
-#line 347 "perly.y" /* yacc.c:1646 */
+#line 350 "perly.y" /* yacc.c:1646 */
{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
break;
case 35:
-#line 349 "perly.y" /* yacc.c:1646 */
+#line 352 "perly.y" /* yacc.c:1646 */
{
SvREFCNT_inc_simple_void(PL_compcv);
utilize((ps[-6].val.ival), (ps[-5].val.ival), (ps[-3].val.opval), (ps[-2].val.opval), (ps[-1].val.opval));
break;
case 36:
-#line 356 "perly.y" /* yacc.c:1646 */
+#line 359 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-4].val.ival),
newCONDOP(0, (ps[-3].val.opval), op_scope((ps[-1].val.opval)), (ps[0].val.opval)));
break;
case 37:
-#line 362 "perly.y" /* yacc.c:1646 */
+#line 365 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-4].val.ival),
newCONDOP(0, (ps[-3].val.opval), (ps[0].val.opval), op_scope((ps[-1].val.opval))));
break;
case 38:
-#line 368 "perly.y" /* yacc.c:1646 */
+#line 371 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-3].val.ival), newGIVENOP((ps[-2].val.opval), op_scope((ps[0].val.opval)), 0));
parser->copline = (line_t)(ps[-5].val.ival);
break;
case 39:
-#line 373 "perly.y" /* yacc.c:1646 */
+#line 376 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = block_end((ps[-3].val.ival), newWHENOP((ps[-2].val.opval), op_scope((ps[0].val.opval)))); }
break;
case 40:
-#line 375 "perly.y" /* yacc.c:1646 */
+#line 378 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newWHENOP(0, op_scope((ps[0].val.opval))); }
break;
case 41:
-#line 377 "perly.y" /* yacc.c:1646 */
+#line 380 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-5].val.ival),
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 42:
-#line 384 "perly.y" /* yacc.c:1646 */
+#line 387 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-5].val.ival),
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 43:
-#line 391 "perly.y" /* yacc.c:1646 */
+#line 394 "perly.y" /* yacc.c:1646 */
{ parser->expect = XTERM; }
break;
case 44:
-#line 393 "perly.y" /* yacc.c:1646 */
+#line 396 "perly.y" /* yacc.c:1646 */
{ parser->expect = XTERM; }
break;
case 45:
-#line 396 "perly.y" /* yacc.c:1646 */
+#line 399 "perly.y" /* yacc.c:1646 */
{
OP *initop = (ps[-9].val.opval);
OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 46:
-#line 411 "perly.y" /* yacc.c:1646 */
+#line 414 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-6].val.ival), newFOROP(0, (ps[-5].val.opval), (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval)));
parser->copline = (line_t)(ps[-8].val.ival);
break;
case 47:
-#line 416 "perly.y" /* yacc.c:1646 */
+#line 419 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-4].val.ival), newFOROP(0,
op_lvalue((ps[-6].val.opval), OP_ENTERLOOP), (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval)));
break;
case 48:
-#line 422 "perly.y" /* yacc.c:1646 */
+#line 425 "perly.y" /* yacc.c:1646 */
{ parser->in_my = 0; (yyval.opval) = my((ps[0].val.opval)); }
break;
case 49:
-#line 424 "perly.y" /* yacc.c:1646 */
+#line 427 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end(
(ps[-7].val.ival),
break;
case 50:
-#line 437 "perly.y" /* yacc.c:1646 */
+#line 440 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-4].val.ival), newFOROP(
0, op_lvalue(newUNOP(OP_REFGEN, 0,
break;
case 51:
-#line 445 "perly.y" /* yacc.c:1646 */
+#line 448 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end((ps[-4].val.ival),
newFOROP(0, (OP*)NULL, (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval)));
break;
case 52:
-#line 451 "perly.y" /* yacc.c:1646 */
+#line 454 "perly.y" /* yacc.c:1646 */
{
/* a block is a loop that happens once */
(yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 53:
-#line 457 "perly.y" /* yacc.c:1646 */
+#line 460 "perly.y" /* yacc.c:1646 */
{
package((ps[-2].val.opval));
if ((ps[-3].val.opval)) {
break;
case 54:
-#line 464 "perly.y" /* yacc.c:1646 */
+#line 467 "perly.y" /* yacc.c:1646 */
{
/* a block is a loop that happens once */
(yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 55:
-#line 472 "perly.y" /* yacc.c:1646 */
+#line 475 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = (ps[-1].val.opval);
}
break;
case 56:
-#line 476 "perly.y" /* yacc.c:1646 */
+#line 479 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = (OP*)NULL;
parser->copline = NOLINE;
break;
case 57:
-#line 484 "perly.y" /* yacc.c:1646 */
+#line 487 "perly.y" /* yacc.c:1646 */
{ OP *list;
if ((ps[0].val.opval)) {
OP *term = (ps[0].val.opval);
break;
case 58:
-#line 501 "perly.y" /* yacc.c:1646 */
+#line 504 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = NULL; }
break;
case 59:
-#line 503 "perly.y" /* yacc.c:1646 */
+#line 506 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_unscope((ps[-1].val.opval)); }
break;
case 60:
-#line 508 "perly.y" /* yacc.c:1646 */
+#line 511 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 61:
-#line 510 "perly.y" /* yacc.c:1646 */
+#line 513 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 62:
-#line 512 "perly.y" /* yacc.c:1646 */
+#line 515 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[0].val.opval), (ps[-2].val.opval)); }
break;
case 63:
-#line 514 "perly.y" /* yacc.c:1646 */
+#line 517 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOGOP(OP_OR, 0, (ps[0].val.opval), (ps[-2].val.opval)); }
break;
case 64:
-#line 516 "perly.y" /* yacc.c:1646 */
+#line 519 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[0].val.opval)), (ps[-2].val.opval)); }
break;
case 65:
-#line 518 "perly.y" /* yacc.c:1646 */
+#line 521 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[0].val.opval), (ps[-2].val.opval)); }
break;
case 66:
-#line 520 "perly.y" /* yacc.c:1646 */
+#line 523 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[0].val.opval), (ps[-2].val.opval), (OP*)NULL);
parser->copline = (line_t)(ps[-1].val.ival); }
break;
case 67:
-#line 523 "perly.y" /* yacc.c:1646 */
+#line 526 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newWHENOP((ps[0].val.opval), op_scope((ps[-2].val.opval))); }
break;
case 68:
-#line 528 "perly.y" /* yacc.c:1646 */
+#line 531 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 69:
-#line 530 "perly.y" /* yacc.c:1646 */
+#line 533 "perly.y" /* yacc.c:1646 */
{
((ps[0].val.opval))->op_flags |= OPf_PARENS;
(yyval.opval) = op_scope((ps[0].val.opval));
break;
case 70:
-#line 535 "perly.y" /* yacc.c:1646 */
+#line 538 "perly.y" /* yacc.c:1646 */
{ parser->copline = (line_t)(ps[-5].val.ival);
(yyval.opval) = newCONDOP(0,
newSTATEOP(OPf_SPECIAL,NULL,(ps[-3].val.opval)),
break;
case 71:
-#line 545 "perly.y" /* yacc.c:1646 */
+#line 548 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 72:
-#line 547 "perly.y" /* yacc.c:1646 */
+#line 550 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_scope((ps[0].val.opval)); }
break;
case 73:
-#line 552 "perly.y" /* yacc.c:1646 */
+#line 555 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = (PL_min_intro_pending &&
PL_max_intro_pending >= PL_min_intro_pending);
intro_my(); }
break;
case 74:
-#line 558 "perly.y" /* yacc.c:1646 */
+#line 561 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 76:
-#line 564 "perly.y" /* yacc.c:1646 */
+#line 567 "perly.y" /* yacc.c:1646 */
{ YYSTYPE tmplval;
(void)scan_num("1", &tmplval);
(yyval.opval) = tmplval.opval; }
break;
case 78:
-#line 572 "perly.y" /* yacc.c:1646 */
+#line 575 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = invert(scalar((ps[0].val.opval))); }
break;
case 79:
-#line 577 "perly.y" /* yacc.c:1646 */
+#line 580 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); intro_my(); }
break;
case 80:
-#line 581 "perly.y" /* yacc.c:1646 */
+#line 584 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); intro_my(); }
break;
case 81:
-#line 584 "perly.y" /* yacc.c:1646 */
+#line 587 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 82:
-#line 585 "perly.y" /* yacc.c:1646 */
+#line 588 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 83:
-#line 589 "perly.y" /* yacc.c:1646 */
+#line 592 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = start_subparse(FALSE, 0);
SAVEFREESV(PL_compcv); }
break;
case 84:
-#line 595 "perly.y" /* yacc.c:1646 */
+#line 598 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = start_subparse(FALSE, CVf_ANON);
SAVEFREESV(PL_compcv); }
break;
case 85:
-#line 600 "perly.y" /* yacc.c:1646 */
+#line 603 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = start_subparse(TRUE, 0);
SAVEFREESV(PL_compcv); }
break;
case 88:
-#line 611 "perly.y" /* yacc.c:1646 */
+#line 614 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 90:
-#line 617 "perly.y" /* yacc.c:1646 */
+#line 620 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 91:
-#line 619 "perly.y" /* yacc.c:1646 */
+#line 622 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 92:
-#line 621 "perly.y" /* yacc.c:1646 */
+#line 624 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 93:
-#line 626 "perly.y" /* yacc.c:1646 */
+#line 629 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 94:
-#line 628 "perly.y" /* yacc.c:1646 */
+#line 631 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
case 95:
-#line 633 "perly.y" /* yacc.c:1646 */
+#line 642 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = 0; (yyval.opval) = (OP*)NULL; }
+
+ break;
+
+ case 96:
+#line 644 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = 0; (yyval.opval) = (ps[0].val.opval); }
+
+ break;
+
+ case 97:
+#line 649 "perly.y" /* yacc.c:1646 */
+ { (yyval.ival) = '@'; }
+
+ break;
+
+ case 98:
+#line 651 "perly.y" /* yacc.c:1646 */
+ { (yyval.ival) = '%'; }
+
+ break;
+
+ case 99:
+#line 655 "perly.y" /* yacc.c:1646 */
{
- /* We shouldn't get here otherwise */
- assert(FEATURE_SIGNATURES_IS_ENABLED);
+ I32 sigil = (ps[-2].val.ival);
+ OP *var = (ps[-1].val.opval);
+ OP *defexpr = (ps[0].val.opval);
+
+ if (parser->sig_slurpy)
+ yyerror("Multiple slurpy parameters not allowed");
+ parser->sig_slurpy = (char)sigil;
+
+ if (defexpr)
+ yyerror("A slurpy parameter may not have "
+ "a default value");
+
+ (yyval.opval) = var ? newSTATEOP(0, NULL, var) : (OP*)NULL;
+ }
+
+ break;
+
+ case 100:
+#line 674 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (OP*)NULL; }
+
+ break;
+
+ case 101:
+#line 676 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newOP(OP_NULL, 0); }
+
+ break;
+
+ case 102:
+#line 678 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
+ break;
+
+ case 103:
+#line 684 "perly.y" /* yacc.c:1646 */
+ {
+ OP *var = (ps[-1].val.opval);
+ OP *defexpr = (ps[0].val.opval);
+
+ if (parser->sig_slurpy)
+ yyerror("Slurpy parameter not last");
+
+ parser->sig_elems++;
+
+ if (defexpr) {
+ parser->sig_optelems++;
+
+ if ( defexpr->op_type == OP_NULL
+ && !(defexpr->op_flags & OPf_KIDS))
+ {
+ /* handle '$=' special case */
+ if (var)
+ yyerror("Optional parameter "
+ "lacks default expression");
+ op_free(defexpr);
+ }
+ else {
+ /* a normal '=default' expression */
+ OP *defop = (OP*)alloc_LOGOP(OP_ARGDEFELEM,
+ defexpr,
+ LINKLIST(defexpr));
+ /* re-purpose op_targ to hold @_ index */
+ defop->op_targ =
+ (PADOFFSET)(parser->sig_elems - 1);
+
+ if (var) {
+ var->op_flags |= OPf_STACKED;
+ (void)op_sibling_splice(var,
+ NULL, 0, defop);
+ scalar(defop);
+ }
+ else
+ var = newUNOP(OP_NULL, 0, defop);
+
+ LINKLIST(var);
+ /* NB: normally the first child of a
+ * logop is executed before the logop,
+ * and it pushes a boolean result
+ * ready for the logop. For ARGDEFELEM,
+ * the op itself does the boolean
+ * calculation, so set the first op to
+ * it instead.
+ */
+ var->op_next = defop;
+ defexpr->op_next = var;
+ }
+ }
+ else {
+ if (parser->sig_optelems)
+ yyerror("Mandatory parameter "
+ "follows optional parameter");
+ }
+
+ (yyval.opval) = var ? newSTATEOP(0, NULL, var) : (OP*)NULL;
+ }
+
+ break;
+
+ case 104:
+#line 749 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = KEY_sigvar; (yyval.opval) = (ps[0].val.opval); }
+
+ break;
+
+ case 105:
+#line 751 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = KEY_sigvar; (yyval.opval) = (ps[0].val.opval); }
+
+ break;
+
+ case 106:
+#line 757 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[-1].val.opval); }
+
+ break;
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__SIGNATURES),
- "The signatures feature is experimental");
- (yyval.opval) = parse_subsignature();
+ case 107:
+#line 759 "perly.y" /* yacc.c:1646 */
+ {
+ (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-2].val.opval), (ps[0].val.opval));
}
break;
- case 96:
-#line 643 "perly.y" /* yacc.c:1646 */
+ case 108:
+#line 763 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
+ break;
+
+ case 109:
+#line 768 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (OP*)NULL; }
+
+ break;
+
+ case 110:
+#line 770 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
+ break;
+
+ case 111:
+#line 774 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-1].val.opval),
- newSTATEOP(0, NULL, sawparens(newNULLLIST())));
- parser->expect = XATTRBLOCK;
+ ENTER;
+ SAVEIV(parser->sig_elems);
+ SAVEIV(parser->sig_optelems);
+ SAVEI8(parser->sig_slurpy);
+ parser->sig_elems = 0;
+ parser->sig_optelems = 0;
+ parser->sig_slurpy = 0;
+ parser->in_my = KEY_sigvar;
+ }
+
+ break;
+
+ case 112:
+#line 786 "perly.y" /* yacc.c:1646 */
+ {
+ OP *sigops = (ps[-1].val.opval);
+ UNOP_AUX_item *aux;
+ OP *check;
+
+ assert(FEATURE_SIGNATURES_IS_ENABLED);
+
+ /* We shouldn't get here otherwise */
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SIGNATURES),
+ "The signatures feature is experimental");
+
+ aux = (UNOP_AUX_item*)PerlMemShared_malloc(
+ sizeof(UNOP_AUX_item) * 3);
+ aux[0].iv = parser->sig_elems;
+ aux[1].iv = parser->sig_optelems;
+ aux[2].iv = parser->sig_slurpy;
+ check = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux);
+ sigops = op_prepend_elem(OP_LINESEQ, check, sigops);
+ sigops = op_prepend_elem(OP_LINESEQ,
+ newSTATEOP(0, NULL, NULL),
+ sigops);
+ /* a nextstate at the end handles context
+ * correctly for an empty sub body */
+ (yyval.opval) = op_append_elem(OP_LINESEQ,
+ sigops,
+ newSTATEOP(0, NULL, NULL));
+
+ parser->in_my = 0;
+ parser->expect = XATTRBLOCK;
+ LEAVE;
}
break;
- case 98:
-#line 652 "perly.y" /* yacc.c:1646 */
+ case 114:
+#line 824 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
- case 99:
-#line 657 "perly.y" /* yacc.c:1646 */
+ case 115:
+#line 829 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
- case 100:
-#line 659 "perly.y" /* yacc.c:1646 */
+ case 116:
+#line 831 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOGOP((ps[-1].val.ival), 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
- case 101:
-#line 661 "perly.y" /* yacc.c:1646 */
+ case 117:
+#line 833 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
- case 103:
-#line 667 "perly.y" /* yacc.c:1646 */
+ case 119:
+#line 839 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[-1].val.opval); }
break;
- case 104:
-#line 669 "perly.y" /* yacc.c:1646 */
+ case 120:
+#line 841 "perly.y" /* yacc.c:1646 */
{
OP* term = (ps[0].val.opval);
(yyval.opval) = op_append_elem(OP_LIST, (ps[-2].val.opval), term);
break;
- case 106:
-#line 678 "perly.y" /* yacc.c:1646 */
+ case 122:
+#line 850 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list((ps[-2].val.ival), OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF((ps[-2].val.ival),(ps[-1].val.opval)), (ps[0].val.opval)) );
}
break;
- case 107:
-#line 682 "perly.y" /* yacc.c:1646 */
+ case 123:
+#line 854 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list((ps[-4].val.ival), OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF((ps[-4].val.ival),(ps[-2].val.opval)), (ps[-1].val.opval)) );
}
break;
- case 108:
-#line 686 "perly.y" /* yacc.c:1646 */
+ case 124:
+#line 858 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, scalar((ps[-5].val.opval)), (ps[-1].val.opval)),
break;
- case 109:
-#line 692 "perly.y" /* yacc.c:1646 */
+ case 125:
+#line 864 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, scalar((ps[-2].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[0].val.opval))));
break;
- case 110:
-#line 697 "perly.y" /* yacc.c:1646 */
+ case 126:
+#line 869 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[-1].val.opval), (ps[0].val.opval)),
break;
- case 111:
-#line 703 "perly.y" /* yacc.c:1646 */
+ case 127:
+#line 875 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[-3].val.opval), (ps[-1].val.opval)),
break;
- case 112:
-#line 709 "perly.y" /* yacc.c:1646 */
+ case 128:
+#line 881 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list((ps[-1].val.ival), 0, (ps[0].val.opval)); }
break;
- case 113:
-#line 711 "perly.y" /* yacc.c:1646 */
+ case 129:
+#line 883 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list((ps[-3].val.ival), 0, (ps[-1].val.opval)); }
break;
- case 114:
-#line 713 "perly.y" /* yacc.c:1646 */
+ case 130:
+#line 885 "perly.y" /* yacc.c:1646 */
{ SvREFCNT_inc_simple_void(PL_compcv);
(yyval.opval) = newANONATTRSUB((ps[-1].val.ival), 0, (OP*)NULL, (ps[0].val.opval)); }
break;
- case 115:
-#line 716 "perly.y" /* yacc.c:1646 */
+ case 131:
+#line 888 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[-1].val.opval), (ps[0].val.opval)), (ps[-4].val.opval)));
break;
- case 118:
-#line 731 "perly.y" /* yacc.c:1646 */
+ case 134:
+#line 903 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[-4].val.opval), scalar((ps[-2].val.opval))); }
break;
- case 119:
-#line 733 "perly.y" /* yacc.c:1646 */
+ case 135:
+#line 905 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[-3].val.opval)), scalar((ps[-1].val.opval)));
}
break;
- case 120:
-#line 736 "perly.y" /* yacc.c:1646 */
+ case 136:
+#line 908 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[-4].val.opval)),OP_RV2AV),
scalar((ps[-1].val.opval)));
break;
- case 121:
-#line 741 "perly.y" /* yacc.c:1646 */
+ case 137:
+#line 913 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[-3].val.opval)),OP_RV2AV),
scalar((ps[-1].val.opval)));
break;
- case 122:
-#line 746 "perly.y" /* yacc.c:1646 */
+ case 138:
+#line 918 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[-4].val.opval)), jmaybe((ps[-2].val.opval)));
}
break;
- case 123:
-#line 749 "perly.y" /* yacc.c:1646 */
+ case 139:
+#line 921 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[-5].val.opval)),OP_RV2HV),
jmaybe((ps[-2].val.opval))); }
break;
- case 124:
-#line 753 "perly.y" /* yacc.c:1646 */
+ case 140:
+#line 925 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[-4].val.opval)),OP_RV2HV),
jmaybe((ps[-2].val.opval))); }
break;
- case 125:
-#line 757 "perly.y" /* yacc.c:1646 */
+ case 141:
+#line 929 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar((ps[-3].val.opval)))); }
break;
- case 126:
-#line 760 "perly.y" /* yacc.c:1646 */
+ case 142:
+#line 932 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[-1].val.opval),
newCVREF(0, scalar((ps[-4].val.opval))))); }
break;
- case 127:
-#line 765 "perly.y" /* yacc.c:1646 */
+ case 143:
+#line 937 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[-1].val.opval),
newCVREF(0, scalar((ps[-3].val.opval))))); }
break;
- case 128:
-#line 769 "perly.y" /* yacc.c:1646 */
+ case 144:
+#line 941 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar((ps[-2].val.opval)))); }
break;
- case 129:
-#line 772 "perly.y" /* yacc.c:1646 */
+ case 145:
+#line 944 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), (ps[-4].val.opval)); }
break;
- case 130:
-#line 774 "perly.y" /* yacc.c:1646 */
+ case 146:
+#line 946 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), (ps[-3].val.opval)); }
break;
- case 131:
-#line 776 "perly.y" /* yacc.c:1646 */
+ case 147:
+#line 948 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), (OP*)NULL); }
break;
- case 132:
-#line 781 "perly.y" /* yacc.c:1646 */
+ case 148:
+#line 953 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[-2].val.opval), (ps[-1].val.ival), (ps[0].val.opval)); }
break;
- case 133:
-#line 783 "perly.y" /* yacc.c:1646 */
+ case 149:
+#line 955 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
break;
- case 134:
-#line 785 "perly.y" /* yacc.c:1646 */
+ case 150:
+#line 957 "perly.y" /* yacc.c:1646 */
{ if ((ps[-1].val.ival) != OP_REPEAT)
scalar((ps[-2].val.opval));
(yyval.opval) = newBINOP((ps[-1].val.ival), 0, (ps[-2].val.opval), scalar((ps[0].val.opval)));
break;
- case 135:
-#line 790 "perly.y" /* yacc.c:1646 */
+ case 151:
+#line 962 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
break;
- case 136:
-#line 792 "perly.y" /* yacc.c:1646 */
+ case 152:
+#line 964 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
break;
- case 137:
-#line 794 "perly.y" /* yacc.c:1646 */
+ case 153:
+#line 966 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
break;
- case 138:
-#line 796 "perly.y" /* yacc.c:1646 */
+ case 154:
+#line 968 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
break;
- case 139:
-#line 798 "perly.y" /* yacc.c:1646 */
+ case 155:
+#line 970 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
break;
- case 140:
-#line 800 "perly.y" /* yacc.c:1646 */
+ case 156:
+#line 972 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
break;
- case 141:
-#line 802 "perly.y" /* yacc.c:1646 */
+ case 157:
+#line 974 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newRANGE((ps[-1].val.ival), scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
break;
- case 142:
-#line 804 "perly.y" /* yacc.c:1646 */
+ case 158:
+#line 976 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
- case 143:
-#line 806 "perly.y" /* yacc.c:1646 */
+ case 159:
+#line 978 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOGOP(OP_OR, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
- case 144:
-#line 808 "perly.y" /* yacc.c:1646 */
+ case 160:
+#line 980 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
- case 145:
-#line 810 "perly.y" /* yacc.c:1646 */
+ case 161:
+#line 982 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = bind_match((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); }
break;
- case 146:
-#line 815 "perly.y" /* yacc.c:1646 */
+ case 162:
+#line 987 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[0].val.opval))); }
break;
- case 147:
-#line 817 "perly.y" /* yacc.c:1646 */
+ case 163:
+#line 989 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 148:
-#line 820 "perly.y" /* yacc.c:1646 */
+ case 164:
+#line 992 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[0].val.opval))); }
break;
- case 149:
-#line 822 "perly.y" /* yacc.c:1646 */
+ case 165:
+#line 994 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP((ps[-1].val.ival), 0, scalar((ps[0].val.opval))); }
break;
- case 150:
-#line 824 "perly.y" /* yacc.c:1646 */
+ case 166:
+#line 996 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_POSTINC, 0,
op_lvalue(scalar((ps[-1].val.opval)), OP_POSTINC)); }
break;
- case 151:
-#line 827 "perly.y" /* yacc.c:1646 */
+ case 167:
+#line 999 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_POSTDEC, 0,
op_lvalue(scalar((ps[-1].val.opval)), OP_POSTDEC));}
break;
- case 152:
-#line 830 "perly.y" /* yacc.c:1646 */
+ case 168:
+#line 1002 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_JOIN, 0,
op_append_elem(
OP_LIST,
break;
- case 153:
-#line 841 "perly.y" /* yacc.c:1646 */
+ case 169:
+#line 1013 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_PREINC, 0,
op_lvalue(scalar((ps[0].val.opval)), OP_PREINC)); }
break;
- case 154:
-#line 844 "perly.y" /* yacc.c:1646 */
+ case 170:
+#line 1016 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_PREDEC, 0,
op_lvalue(scalar((ps[0].val.opval)), OP_PREDEC)); }
break;
- case 155:
-#line 851 "perly.y" /* yacc.c:1646 */
+ case 171:
+#line 1023 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newANONLIST((ps[-1].val.opval)); }
break;
- case 156:
-#line 853 "perly.y" /* yacc.c:1646 */
+ case 172:
+#line 1025 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newANONLIST((OP*)NULL);}
break;
- case 157:
-#line 855 "perly.y" /* yacc.c:1646 */
+ case 173:
+#line 1027 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newANONHASH((ps[-2].val.opval)); }
break;
- case 158:
-#line 857 "perly.y" /* yacc.c:1646 */
+ case 174:
+#line 1029 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newANONHASH((OP*)NULL); }
break;
- case 159:
-#line 859 "perly.y" /* yacc.c:1646 */
+ case 175:
+#line 1031 "perly.y" /* yacc.c:1646 */
{ SvREFCNT_inc_simple_void(PL_compcv);
(yyval.opval) = newANONATTRSUB((ps[-3].val.ival), (ps[-2].val.opval), (ps[-1].val.opval), (ps[0].val.opval)); }
break;
- case 160:
-#line 862 "perly.y" /* yacc.c:1646 */
+ case 176:
+#line 1034 "perly.y" /* yacc.c:1646 */
{
OP *body;
if (parser->copline > (line_t)(ps[-2].val.ival))
break;
- case 161:
-#line 876 "perly.y" /* yacc.c:1646 */
+ case 177:
+#line 1048 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = dofile((ps[0].val.opval), (ps[-1].val.ival));}
break;
- case 162:
-#line 878 "perly.y" /* yacc.c:1646 */
+ case 178:
+#line 1050 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[0].val.opval)));}
break;
- case 167:
-#line 886 "perly.y" /* yacc.c:1646 */
+ case 183:
+#line 1058 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newCONDOP(0, (ps[-4].val.opval), (ps[-2].val.opval), (ps[0].val.opval)); }
break;
- case 168:
-#line 888 "perly.y" /* yacc.c:1646 */
+ case 184:
+#line 1060 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[0].val.opval)); }
break;
- case 169:
-#line 890 "perly.y" /* yacc.c:1646 */
+ case 185:
+#line 1062 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_REFGEN, 0, localize((ps[0].val.opval),1)); }
break;
- case 170:
-#line 892 "perly.y" /* yacc.c:1646 */
+ case 186:
+#line 1064 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 171:
-#line 894 "perly.y" /* yacc.c:1646 */
+ case 187:
+#line 1066 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = localize((ps[0].val.opval),0); }
break;
- case 172:
-#line 896 "perly.y" /* yacc.c:1646 */
+ case 188:
+#line 1068 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = sawparens((ps[-1].val.opval)); }
break;
- case 173:
-#line 898 "perly.y" /* yacc.c:1646 */
+ case 189:
+#line 1070 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 174:
-#line 900 "perly.y" /* yacc.c:1646 */
+ case 190:
+#line 1072 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = sawparens(newNULLLIST()); }
break;
- case 175:
-#line 902 "perly.y" /* yacc.c:1646 */
+ case 191:
+#line 1074 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 176:
-#line 904 "perly.y" /* yacc.c:1646 */
+ case 192:
+#line 1076 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 177:
-#line 906 "perly.y" /* yacc.c:1646 */
+ case 193:
+#line 1078 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 178:
-#line 908 "perly.y" /* yacc.c:1646 */
+ case 194:
+#line 1080 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 179:
-#line 910 "perly.y" /* yacc.c:1646 */
+ case 195:
+#line 1082 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[0].val.opval), OP_AV2ARYLEN));}
break;
- case 180:
-#line 912 "perly.y" /* yacc.c:1646 */
+ case 196:
+#line 1084 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 181:
-#line 914 "perly.y" /* yacc.c:1646 */
+ case 197:
+#line 1086 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
break;
- case 182:
-#line 924 "perly.y" /* yacc.c:1646 */
+ case 198:
+#line 1096 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_prepend_elem(OP_KVASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_KVASLICE, 0,
break;
- case 183:
-#line 934 "perly.y" /* yacc.c:1646 */
+ case 199:
+#line 1106 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
break;
- case 184:
-#line 944 "perly.y" /* yacc.c:1646 */
+ case 200:
+#line 1116 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_prepend_elem(OP_KVHSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_KVHSLICE, 0,
break;
- case 185:
-#line 954 "perly.y" /* yacc.c:1646 */
+ case 201:
+#line 1126 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 186:
-#line 956 "perly.y" /* yacc.c:1646 */
+ case 202:
+#line 1128 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[0].val.opval))); }
break;
- case 187:
-#line 958 "perly.y" /* yacc.c:1646 */
+ case 203:
+#line 1130 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[-2].val.opval)));
}
break;
- case 188:
-#line 961 "perly.y" /* yacc.c:1646 */
+ case 204:
+#line 1133 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[-1].val.opval), scalar((ps[-3].val.opval))));
break;
- case 189:
-#line 966 "perly.y" /* yacc.c:1646 */
+ case 205:
+#line 1138 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[0].val.opval), scalar((ps[-1].val.opval))));
}
break;
- case 190:
-#line 970 "perly.y" /* yacc.c:1646 */
+ case 206:
+#line 1142 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newSVREF((ps[-3].val.opval)); }
break;
- case 191:
-#line 972 "perly.y" /* yacc.c:1646 */
+ case 207:
+#line 1144 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newAVREF((ps[-3].val.opval)); }
break;
- case 192:
-#line 974 "perly.y" /* yacc.c:1646 */
+ case 208:
+#line 1146 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newHVREF((ps[-3].val.opval)); }
break;
- case 193:
-#line 976 "perly.y" /* yacc.c:1646 */
+ case 209:
+#line 1148 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, 0,
scalar(newCVREF((ps[-1].val.ival),(ps[-3].val.opval)))); }
break;
- case 194:
-#line 979 "perly.y" /* yacc.c:1646 */
+ case 210:
+#line 1151 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newGVREF(0,(ps[-3].val.opval)); }
break;
- case 195:
-#line 981 "perly.y" /* yacc.c:1646 */
+ case 211:
+#line 1153 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newOP((ps[0].val.ival), OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
- case 196:
-#line 984 "perly.y" /* yacc.c:1646 */
+ case 212:
+#line 1156 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newLOOPEX((ps[-1].val.ival),(ps[0].val.opval)); }
break;
- case 197:
-#line 986 "perly.y" /* yacc.c:1646 */
+ case 213:
+#line 1158 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[0].val.opval))); }
break;
- case 198:
-#line 988 "perly.y" /* yacc.c:1646 */
+ case 214:
+#line 1160 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newOP((ps[0].val.ival), 0); }
break;
- case 199:
-#line 990 "perly.y" /* yacc.c:1646 */
+ case 215:
+#line 1162 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP((ps[-1].val.ival), 0, (ps[0].val.opval)); }
break;
- case 200:
-#line 992 "perly.y" /* yacc.c:1646 */
+ case 216:
+#line 1164 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP((ps[-1].val.ival), 0, (ps[0].val.opval)); }
break;
- case 201:
-#line 994 "perly.y" /* yacc.c:1646 */
+ case 217:
+#line 1166 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newOP(OP_REQUIRE, (ps[0].val.ival) ? OPf_SPECIAL : 0); }
break;
- case 202:
-#line 996 "perly.y" /* yacc.c:1646 */
+ case 218:
+#line 1168 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_REQUIRE, (ps[-1].val.ival) ? OPf_SPECIAL : 0, (ps[0].val.opval)); }
break;
- case 203:
-#line 998 "perly.y" /* yacc.c:1646 */
+ case 219:
+#line 1170 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[0].val.opval))); }
break;
- case 204:
-#line 1000 "perly.y" /* yacc.c:1646 */
+ case 220:
+#line 1172 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[0].val.opval), scalar((ps[-1].val.opval)))); }
break;
- case 205:
-#line 1003 "perly.y" /* yacc.c:1646 */
+ case 221:
+#line 1175 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newOP((ps[0].val.ival), 0); }
break;
- case 206:
-#line 1005 "perly.y" /* yacc.c:1646 */
+ case 222:
+#line 1177 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newOP((ps[-2].val.ival), 0);}
break;
- case 207:
-#line 1007 "perly.y" /* yacc.c:1646 */
+ case 223:
+#line 1179 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 208:
-#line 1009 "perly.y" /* yacc.c:1646 */
+ case 224:
+#line 1181 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[-2].val.opval); }
break;
- case 209:
-#line 1011 "perly.y" /* yacc.c:1646 */
+ case 225:
+#line 1183 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[0].val.opval))); }
break;
- case 210:
-#line 1013 "perly.y" /* yacc.c:1646 */
+ case 226:
+#line 1185 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = ((ps[-2].val.ival) == OP_NOT)
? newUNOP((ps[-2].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0)))
: newOP((ps[-2].val.ival), OPf_SPECIAL); }
break;
- case 211:
-#line 1017 "perly.y" /* yacc.c:1646 */
+ case 227:
+#line 1189 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP((ps[-3].val.ival), 0, (ps[-1].val.opval)); }
break;
- case 212:
-#line 1019 "perly.y" /* yacc.c:1646 */
+ case 228:
+#line 1191 "perly.y" /* yacc.c:1646 */
{
if ( (ps[0].val.opval)->op_type != OP_TRANS
&& (ps[0].val.opval)->op_type != OP_TRANSR
break;
- case 213:
-#line 1030 "perly.y" /* yacc.c:1646 */
+ case 229:
+#line 1202 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = pmruntime((ps[-5].val.opval), (ps[-2].val.opval), (ps[-1].val.opval), 1, (ps[-4].val.ival)); }
break;
- case 216:
-#line 1034 "perly.y" /* yacc.c:1646 */
+ case 232:
+#line 1206 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
break;
- case 218:
-#line 1043 "perly.y" /* yacc.c:1646 */
+ case 234:
+#line 1215 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = my_attrs((ps[-1].val.opval),(ps[0].val.opval)); }
break;
- case 219:
-#line 1045 "perly.y" /* yacc.c:1646 */
+ case 235:
+#line 1217 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = localize((ps[0].val.opval),1); }
break;
- case 220:
-#line 1047 "perly.y" /* yacc.c:1646 */
+ case 236:
+#line 1219 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_REFGEN, 0, my_attrs((ps[-1].val.opval),(ps[0].val.opval))); }
break;
- case 221:
-#line 1052 "perly.y" /* yacc.c:1646 */
+ case 237:
+#line 1224 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = sawparens((ps[-1].val.opval)); }
break;
- case 222:
-#line 1054 "perly.y" /* yacc.c:1646 */
+ case 238:
+#line 1226 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = sawparens(newNULLLIST()); }
break;
- case 223:
-#line 1057 "perly.y" /* yacc.c:1646 */
+ case 239:
+#line 1229 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 224:
-#line 1059 "perly.y" /* yacc.c:1646 */
+ case 240:
+#line 1231 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 225:
-#line 1061 "perly.y" /* yacc.c:1646 */
+ case 241:
+#line 1233 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 226:
-#line 1066 "perly.y" /* yacc.c:1646 */
+ case 242:
+#line 1238 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
- case 227:
-#line 1068 "perly.y" /* yacc.c:1646 */
+ case 243:
+#line 1240 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 228:
-#line 1072 "perly.y" /* yacc.c:1646 */
+ case 244:
+#line 1244 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
- case 229:
-#line 1074 "perly.y" /* yacc.c:1646 */
+ case 245:
+#line 1246 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 230:
-#line 1078 "perly.y" /* yacc.c:1646 */
+ case 246:
+#line 1250 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (OP*)NULL; }
break;
- case 231:
-#line 1080 "perly.y" /* yacc.c:1646 */
+ case 247:
+#line 1252 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
- case 232:
-#line 1086 "perly.y" /* yacc.c:1646 */
+ case 248:
+#line 1258 "perly.y" /* yacc.c:1646 */
{ parser->in_my = 0; (yyval.opval) = my((ps[0].val.opval)); }
break;
- case 240:
-#line 1103 "perly.y" /* yacc.c:1646 */
+ case 256:
+#line 1275 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newCVREF((ps[-1].val.ival),(ps[0].val.opval)); }
break;
- case 241:
-#line 1107 "perly.y" /* yacc.c:1646 */
+ case 257:
+#line 1279 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newSVREF((ps[0].val.opval)); }
break;
- case 242:
-#line 1111 "perly.y" /* yacc.c:1646 */
+ case 258:
+#line 1283 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newAVREF((ps[0].val.opval));
if ((yyval.opval)) (yyval.opval)->op_private |= (ps[-1].val.ival);
}
break;
- case 243:
-#line 1117 "perly.y" /* yacc.c:1646 */
+ case 259:
+#line 1289 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newHVREF((ps[0].val.opval));
if ((yyval.opval)) (yyval.opval)->op_private |= (ps[-1].val.ival);
}
break;
- case 244:
-#line 1123 "perly.y" /* yacc.c:1646 */
+ case 260:
+#line 1295 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newAVREF((ps[0].val.opval)); }
break;
- case 245:
-#line 1125 "perly.y" /* yacc.c:1646 */
+ case 261:
+#line 1297 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newAVREF((ps[-3].val.opval)); }
break;
- case 246:
-#line 1129 "perly.y" /* yacc.c:1646 */
+ case 262:
+#line 1301 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newGVREF(0,(ps[0].val.opval)); }
break;
- case 248:
-#line 1134 "perly.y" /* yacc.c:1646 */
+ case 264:
+#line 1306 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newAVREF((ps[-2].val.opval)); }
break;
- case 250:
-#line 1139 "perly.y" /* yacc.c:1646 */
+ case 266:
+#line 1311 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newHVREF((ps[-2].val.opval)); }
break;
- case 252:
-#line 1144 "perly.y" /* yacc.c:1646 */
+ case 268:
+#line 1316 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newGVREF(0,(ps[-2].val.opval)); }
break;
- case 253:
-#line 1149 "perly.y" /* yacc.c:1646 */
+ case 269:
+#line 1321 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = scalar((ps[0].val.opval)); }
break;
- case 254:
-#line 1151 "perly.y" /* yacc.c:1646 */
+ case 270:
+#line 1323 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = scalar((ps[0].val.opval)); }
break;
- case 255:
-#line 1153 "perly.y" /* yacc.c:1646 */
+ case 271:
+#line 1325 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_scope((ps[0].val.opval)); }
break;
- case 256:
-#line 1156 "perly.y" /* yacc.c:1646 */
+ case 272:
+#line 1328 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = (ps[0].val.opval); }
break;
/* Generated from:
- * fba24dfc68a3a84c9ae95cb9e14cc156ac487e6f3228cdf84c166d3cd820e59a perly.y
+ * 1a8fc0f841dee6e563463a6b91bf9c410b47437c760f485a16d87ade3d66bf1d perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
#define PERL_IN_PERLY_C
#include "perl.h"
#include "feature.h"
+#include "keywords.h"
typedef unsigned char yytype_uint8;
typedef signed char yytype_int8;
int
Perl_yyparse (pTHX_ int gramtype)
{
+ dVAR;
int yystate;
int yyn;
int yyresult;
/* Generated from:
- * fba24dfc68a3a84c9ae95cb9e14cc156ac487e6f3228cdf84c166d3cd820e59a perly.y
+ * 1a8fc0f841dee6e563463a6b91bf9c410b47437c760f485a16d87ade3d66bf1d perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
#define YYFINAL 14
/* YYLAST -- Last index in YYTABLE. */
-#define YYLAST 3111
+#define YYLAST 3085
/* YYNTOKENS -- Number of terminals. */
#define YYNTOKENS 105
/* YYNNTS -- Number of nonterminals. */
-#define YYNNTS 78
+#define YYNNTS 86
/* YYNRULES -- Number of rules. */
-#define YYNRULES 256
+#define YYNRULES 272
/* YYNSTATES -- Number of states. */
-#define YYNSTATES 521
+#define YYNSTATES 539
/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned
by yylex, with out-of-bounds checking. */
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
- 0, 115, 115, 114, 125, 124, 134, 133, 146, 145,
- 158, 157, 170, 169, 181, 189, 197, 201, 209, 215,
- 216, 226, 227, 236, 240, 244, 248, 255, 257, 268,
- 267, 301, 300, 339, 347, 346, 355, 361, 367, 372,
- 374, 376, 383, 391, 393, 390, 410, 415, 422, 421,
- 436, 444, 450, 457, 456, 471, 475, 483, 501, 502,
- 507, 509, 511, 513, 515, 517, 519, 522, 528, 529,
- 534, 545, 546, 552, 558, 559, 564, 567, 571, 576,
- 580, 584, 585, 589, 595, 600, 605, 606, 611, 612,
- 617, 618, 620, 625, 627, 633, 632, 651, 652, 656,
- 658, 660, 662, 666, 668, 673, 677, 681, 685, 691,
- 696, 702, 708, 710, 713, 712, 723, 724, 728, 732,
- 735, 740, 745, 748, 752, 756, 759, 764, 768, 771,
- 773, 775, 780, 782, 784, 789, 791, 793, 795, 797,
- 799, 801, 803, 805, 807, 809, 814, 816, 819, 821,
- 823, 826, 829, 840, 843, 850, 852, 854, 856, 858,
- 861, 875, 877, 881, 882, 883, 884, 885, 887, 889,
- 891, 893, 895, 897, 899, 901, 903, 905, 907, 909,
- 911, 913, 923, 933, 943, 953, 955, 957, 960, 965,
- 969, 971, 973, 975, 978, 980, 983, 985, 987, 989,
- 991, 993, 995, 997, 999, 1002, 1004, 1006, 1008, 1010,
- 1012, 1016, 1019, 1018, 1031, 1032, 1033, 1038, 1042, 1044,
- 1046, 1051, 1053, 1056, 1058, 1060, 1065, 1067, 1072, 1073,
- 1078, 1079, 1085, 1089, 1090, 1091, 1094, 1095, 1098, 1099,
- 1102, 1106, 1110, 1116, 1122, 1124, 1128, 1132, 1133, 1137,
- 1138, 1142, 1143, 1148, 1150, 1152, 1155
+ 0, 118, 118, 117, 128, 127, 137, 136, 149, 148,
+ 161, 160, 173, 172, 184, 192, 200, 204, 212, 218,
+ 219, 229, 230, 239, 243, 247, 251, 258, 260, 271,
+ 270, 304, 303, 342, 350, 349, 358, 364, 370, 375,
+ 377, 379, 386, 394, 396, 393, 413, 418, 425, 424,
+ 439, 447, 453, 460, 459, 474, 478, 486, 504, 505,
+ 510, 512, 514, 516, 518, 520, 522, 525, 531, 532,
+ 537, 548, 549, 555, 561, 562, 567, 570, 574, 579,
+ 583, 587, 588, 592, 598, 603, 608, 609, 614, 615,
+ 620, 621, 623, 628, 630, 642, 643, 648, 650, 654,
+ 674, 675, 677, 683, 748, 750, 756, 758, 762, 768,
+ 769, 774, 773, 823, 824, 828, 830, 832, 834, 838,
+ 840, 845, 849, 853, 857, 863, 868, 874, 880, 882,
+ 885, 884, 895, 896, 900, 904, 907, 912, 917, 920,
+ 924, 928, 931, 936, 940, 943, 945, 947, 952, 954,
+ 956, 961, 963, 965, 967, 969, 971, 973, 975, 977,
+ 979, 981, 986, 988, 991, 993, 995, 998, 1001, 1012,
+ 1015, 1022, 1024, 1026, 1028, 1030, 1033, 1047, 1049, 1053,
+ 1054, 1055, 1056, 1057, 1059, 1061, 1063, 1065, 1067, 1069,
+ 1071, 1073, 1075, 1077, 1079, 1081, 1083, 1085, 1095, 1105,
+ 1115, 1125, 1127, 1129, 1132, 1137, 1141, 1143, 1145, 1147,
+ 1150, 1152, 1155, 1157, 1159, 1161, 1163, 1165, 1167, 1169,
+ 1171, 1174, 1176, 1178, 1180, 1182, 1184, 1188, 1191, 1190,
+ 1203, 1204, 1205, 1210, 1214, 1216, 1218, 1223, 1225, 1228,
+ 1230, 1232, 1237, 1239, 1244, 1245, 1250, 1251, 1257, 1261,
+ 1262, 1263, 1266, 1267, 1270, 1271, 1274, 1278, 1282, 1288,
+ 1294, 1296, 1300, 1304, 1305, 1309, 1310, 1314, 1315, 1320,
+ 1322, 1324, 1327
};
#endif
"$@13", "formline", "formarg", "sideff", "else", "cont", "mintro",
"nexpr", "texpr", "iexpr", "mexpr", "mnexpr", "formname", "startsub",
"startanonsub", "startformsub", "subname", "proto", "subattrlist",
- "myattrlist", "subsignature", "@14", "optsubbody", "expr", "listexpr",
- "listop", "@15", "method", "subscripted", "termbinop", "termunop",
- "anonymous", "termdo", "term", "@16", "myattrterm", "myterm",
- "optlistexpr", "optexpr", "optrepl", "my_scalar", "my_var",
- "refgen_topic", "my_refgen", "amper", "scalar", "ary", "hsh", "arylen",
- "star", "sliceme", "kvslice", "gelem", "indirob", YY_NULLPTR
+ "myattrlist", "sigvarname", "sigslurpsigil", "sigslurpelem",
+ "sigdefault", "sigscalarelem", "sigelem", "siglist", "siglistornull",
+ "subsignature", "$@14", "optsubbody", "expr", "listexpr", "listop",
+ "@15", "method", "subscripted", "termbinop", "termunop", "anonymous",
+ "termdo", "term", "@16", "myattrterm", "myterm", "optlistexpr",
+ "optexpr", "optrepl", "my_scalar", "my_var", "refgen_topic", "my_refgen",
+ "amper", "scalar", "ary", "hsh", "arylen", "star", "sliceme", "kvslice",
+ "gelem", "indirob", YY_NULLPTR
};
#endif
};
# endif
-#define YYPACT_NINF -412
+#define YYPACT_NINF -440
#define yypact_value_is_default(Yystate) \
- (!!((Yystate) == (-412)))
+ (!!((Yystate) == (-440)))
-#define YYTABLE_NINF -252
+#define YYTABLE_NINF -268
#define yytable_value_is_error(Yytable_value) \
- (!!((Yytable_value) == (-252)))
+ (!!((Yytable_value) == (-268)))
/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
STATE-NUM. */
static const yytype_int16 yypact[] =
{
- 903, -412, -412, -412, -412, -412, -412, 8, -412, 2810,
- 16, 1502, 1407, -412, -412, -412, 1973, 2810, 2810, 31,
- 31, 31, -412, 31, 31, -412, -412, 46, -66, -412,
- 2810, -412, -412, -412, 2810, -412, -54, -20, -19, 1880,
- 1785, 31, 1880, 2066, 35, 2810, 62, 2810, 2810, 2810,
- 2810, 2810, 2810, 2810, 2159, 31, 31, 341, -13, -412,
- 7, -412, -412, -412, -412, 2971, -412, -412, -2, 73,
- 79, 82, -412, 76, 123, 180, 92, -412, -412, -412,
- -412, -412, 35, 90, -412, 18, 28, 36, 47, 167,
- 88, 104, 16, -412, 78, -412, 102, 1971, 1407, -412,
- -412, -412, 647, 742, -412, 77, 731, 731, -412, -412,
- -412, -412, -412, -412, -412, 2810, 117, 118, 2810, 122,
- 367, 16, -4, 2971, 126, 2252, 1785, -412, 367, 545,
- -13, -412, 438, 2810, -412, -412, 367, 212, 100, -412,
- -412, 2810, 367, 2903, 2345, 157, -412, -412, -412, 367,
- -13, 731, 731, 731, 71, 71, 219, 221, -412, -412,
- 2810, 2810, 2810, 2810, 2810, 2810, 2438, 2810, 2810, 2810,
- 2810, 2810, 2810, 2810, 2810, 2810, 2810, 2810, 2810, 2810,
- 2810, 2810, -412, -412, -412, 245, 2531, 2810, 2810, 2810,
- 2810, 2810, 2810, 2810, -412, 209, -412, 213, -412, -412,
- -412, -412, -412, 144, 55, -412, -412, 139, -412, -412,
- -412, 16, -412, -412, 2810, 2810, 2810, 2810, 2810, 2810,
- -412, -412, -412, -412, -412, 2810, 2810, 97, -412, -412,
- -412, 141, 173, -412, -412, 256, 145, 2810, -13, -412,
- 242, -412, 2624, 731, 157, 52, 57, 58, -412, 312,
- 230, -412, 2810, 244, 193, 193, -412, 2971, 201, 103,
- -412, 346, 1584, 483, 1768, 724, 502, 2971, 2929, 468,
- 468, 1675, 408, 1863, 630, 731, 731, 2810, 2810, 170,
- 177, 184, -412, 186, 2717, 11, 187, 225, -412, -412,
- 473, 218, 119, 259, 125, 279, 132, 309, 837, -412,
- 252, 235, 2, 288, 2810, 2810, 2810, 2810, -412, 207,
- -412, -412, 236, -412, -412, -412, -412, 1596, 23, -412,
- 2810, 2810, -412, 341, -412, 341, 341, 341, 341, 341,
- 222, -30, -412, 2810, -412, 173, 323, 16, -412, -412,
- 534, -412, 30, 540, -412, -412, -412, 190, 2810, 340,
- -412, -412, 2810, 329, 208, -412, -412, -412, -412, -412,
- 632, -412, -412, 2810, -412, 352, -412, 354, -412, 380,
- -412, 387, -412, -412, -412, 328, -412, -412, -412, 336,
- 301, 341, 302, 306, 341, 307, 308, -412, -412, -412,
- -412, 310, 325, 264, -412, 2810, 334, 335, -412, 2810,
- 338, -412, 343, 426, -412, -412, -412, 42, -412, 211,
- -412, 3013, 429, -412, -412, 344, -412, -412, -412, -412,
- 355, 173, 141, -412, 2810, -412, -412, 435, 435, 2810,
- 2810, 435, -412, 360, 356, 435, 435, 341, -412, -412,
- -412, -412, -412, -412, 390, 5, 173, -412, 370, 435,
- 435, -412, 32, 32, 373, 374, 78, 2810, 2810, 435,
- -412, -412, 932, -412, -412, -412, -412, 466, 1027, -412,
- 78, 78, -412, 435, 376, -412, -412, 435, 435, -412,
- 382, 388, 78, -412, 29, -412, -412, -412, -412, 1122,
- -412, 2810, 78, 78, -412, 435, -412, 411, 471, -412,
- 1217, -412, 392, -412, -412, -412, 78, -412, -412, -412,
- -412, 435, 1690, -412, 1312, 32, 402, -412, -412, 435,
- -412
+ 824, -440, -440, -440, -440, -440, -440, 21, -440, 2826,
+ 44, 1518, 1423, -440, -440, -440, 1989, 2826, 2826, 60,
+ 60, 60, -440, 60, 60, -440, -440, 8, -68, -440,
+ 2826, -440, -440, -440, 2826, -440, -46, -29, -18, 1896,
+ 1801, 60, 1896, 2082, 16, 2826, 137, 2826, 2826, 2826,
+ 2826, 2826, 2826, 2826, 2175, 60, 60, 170, 36, -440,
+ 7, -440, -440, -440, -440, 2945, -440, -440, 17, 126,
+ 209, 221, -440, 89, 239, 266, 113, -440, -440, -440,
+ -440, -440, 16, 106, -440, 29, 32, 57, 61, 149,
+ 66, 70, 44, -440, 102, -440, 116, 325, 1423, -440,
+ -440, -440, 663, 758, -440, 195, 442, 442, -440, -440,
+ -440, -440, -440, -440, -440, 2826, 73, 122, 2826, 127,
+ 318, 44, -8, 2945, 142, 2268, 1801, -440, 318, 561,
+ 36, -440, 485, 2826, -440, -440, 318, 215, 90, -440,
+ -440, 2826, 318, 2919, 2361, 186, -440, -440, -440, 318,
+ 36, 442, 442, 442, 535, 535, 252, 256, -440, -440,
+ 2826, 2826, 2826, 2826, 2826, 2826, 2454, 2826, 2826, 2826,
+ 2826, 2826, 2826, 2826, 2826, 2826, 2826, 2826, 2826, 2826,
+ 2826, 2826, -440, -440, -440, 72, 2547, 2826, 2826, 2826,
+ 2826, 2826, 2826, 2826, -440, 244, -440, 260, -440, -440,
+ -440, -440, -440, 190, 23, -440, -440, 184, -440, -440,
+ -440, 44, -440, -440, 2826, 2826, 2826, 2826, 2826, 2826,
+ -440, -440, -440, -440, -440, 2826, 2826, 217, -440, -440,
+ -440, 194, 227, -440, -440, 295, 187, 2826, 36, -440,
+ 296, -440, 2640, 442, 186, 47, 52, 75, -440, 309,
+ 284, -440, 2826, 301, 251, 251, -440, 2945, 160, 230,
+ -440, 455, 1600, 518, 1879, 498, 646, 2945, 369, 1692,
+ 1692, 419, 1786, 1972, 531, 442, 442, 2826, 2826, 224,
+ 229, 231, -440, 232, 2733, 48, 243, 274, -440, -440,
+ 475, 192, 235, 370, 246, 399, 250, 408, 853, -440,
+ 338, 290, -2, 355, 2826, 2826, 2826, 2826, -440, 299,
+ -440, -440, 297, -440, -440, -440, -440, 1612, 31, -440,
+ 2826, 2826, -440, 170, -440, 170, 170, 170, 170, 170,
+ 303, 19, -440, 2826, -440, 227, 380, 44, -440, -440,
+ 576, -440, 98, 648, -440, -440, -440, 264, 2826, 402,
+ -440, -440, 2826, 418, 270, -440, -440, -440, -440, -440,
+ 661, -440, -440, 2826, -440, 409, -440, 412, -440, 415,
+ -440, 416, -440, -440, -440, 386, -440, -440, -440, 411,
+ 333, 170, 336, 337, 170, 339, 341, -440, -440, -440,
+ -440, 340, 345, 312, -440, 2826, 358, 359, -440, 2826,
+ 363, -440, 112, 459, -440, -440, -440, 107, -440, 275,
+ -440, 2987, 465, -440, -440, 377, -440, -440, -440, -440,
+ 368, 227, 194, -440, 2826, -440, -440, 477, 477, 2826,
+ 2826, 477, -440, 384, 389, 477, 477, 170, -440, -440,
+ -440, 464, 464, -440, -440, -440, 413, 396, -440, -440,
+ -440, -440, 427, 5, 227, -440, 398, 477, 477, -440,
+ 134, 134, 414, 421, 102, 2826, 2826, 477, -440, -440,
+ -440, 423, 423, 112, -440, 948, -440, -440, -440, -440,
+ 499, 1043, -440, 102, 102, -440, 477, 407, -440, -440,
+ 477, 477, -440, 422, 433, 102, 2826, -440, -440, -440,
+ -440, 3, -440, -440, -440, -440, 1138, -440, 2826, 102,
+ 102, -440, 477, -440, 2945, 452, 493, -440, 1233, -440,
+ 436, -440, -440, -440, 102, -440, -440, -440, -440, 477,
+ 1706, -440, 1328, 134, 448, -440, -440, 477, -440
};
/* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM.
means the default is an error. */
static const yytype_uint16 yydefact[] =
{
- 0, 2, 4, 6, 8, 10, 12, 0, 16, 228,
+ 0, 2, 4, 6, 8, 10, 12, 0, 16, 244,
0, 0, 0, 19, 1, 19, 0, 0, 0, 0,
- 0, 0, 214, 0, 0, 185, 212, 173, 207, 209,
- 203, 84, 217, 84, 195, 216, 205, 0, 0, 198,
- 226, 0, 0, 0, 0, 0, 0, 201, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 229, 102, 215,
- 180, 163, 164, 165, 166, 105, 170, 5, 186, 175,
- 178, 177, 179, 176, 0, 0, 0, 16, 7, 60,
+ 0, 0, 230, 0, 0, 201, 228, 189, 223, 225,
+ 219, 84, 233, 84, 211, 232, 221, 0, 0, 214,
+ 242, 0, 0, 0, 0, 0, 0, 217, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 245, 118, 231,
+ 196, 179, 180, 181, 182, 121, 186, 5, 202, 191,
+ 194, 193, 195, 192, 0, 0, 0, 16, 7, 60,
27, 85, 0, 0, 83, 0, 0, 0, 0, 0,
0, 0, 0, 56, 71, 9, 0, 61, 0, 11,
- 24, 23, 0, 0, 156, 0, 146, 147, 253, 256,
- 255, 254, 242, 243, 240, 226, 0, 0, 0, 0,
- 204, 0, 88, 196, 0, 0, 228, 199, 200, 253,
- 227, 112, 254, 0, 244, 162, 161, 0, 0, 86,
- 87, 226, 171, 0, 0, 219, 223, 225, 224, 202,
- 197, 148, 149, 168, 153, 154, 174, 0, 241, 246,
- 0, 0, 0, 103, 0, 0, 0, 0, 0, 0,
+ 24, 23, 0, 0, 172, 0, 162, 163, 269, 272,
+ 271, 270, 258, 259, 256, 242, 0, 0, 0, 0,
+ 220, 0, 88, 212, 0, 0, 244, 215, 216, 269,
+ 243, 128, 270, 0, 260, 178, 177, 0, 0, 86,
+ 87, 242, 187, 0, 0, 235, 239, 241, 240, 218,
+ 213, 164, 165, 184, 169, 170, 190, 0, 257, 262,
+ 0, 0, 0, 119, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 150, 151, 152, 0, 0, 0, 0, 0,
+ 0, 0, 166, 167, 168, 0, 0, 0, 0, 0,
0, 0, 0, 0, 19, 82, 83, 0, 34, 16,
16, 16, 16, 16, 0, 16, 16, 0, 16, 16,
40, 0, 52, 55, 0, 0, 0, 0, 0, 0,
- 26, 25, 20, 155, 110, 228, 0, 0, 208, 114,
- 89, 0, 90, 206, 210, 0, 0, 0, 106, 158,
- 0, 189, 0, 169, 0, 175, 178, 177, 222, 0,
- 94, 218, 0, 172, 100, 101, 99, 104, 0, 0,
- 128, 0, 141, 137, 138, 134, 135, 132, 0, 143,
- 144, 142, 140, 139, 136, 145, 133, 0, 0, 248,
- 250, 0, 116, 0, 0, 0, 252, 109, 117, 187,
+ 26, 25, 20, 171, 126, 244, 0, 0, 224, 130,
+ 89, 0, 90, 222, 226, 0, 0, 0, 122, 174,
+ 0, 205, 0, 185, 0, 191, 194, 193, 238, 0,
+ 94, 234, 0, 188, 116, 117, 115, 120, 0, 0,
+ 144, 0, 157, 153, 154, 150, 151, 148, 0, 159,
+ 160, 158, 156, 155, 152, 161, 149, 0, 0, 264,
+ 266, 0, 132, 0, 0, 0, 268, 125, 133, 203,
0, 0, 0, 0, 0, 0, 0, 0, 0, 81,
- 0, 29, 0, 0, 76, 0, 0, 0, 238, 0,
- 239, 236, 0, 237, 233, 234, 235, 0, 0, 16,
+ 0, 29, 0, 0, 76, 0, 0, 0, 254, 0,
+ 255, 252, 0, 253, 249, 250, 251, 0, 0, 16,
0, 0, 72, 64, 65, 78, 62, 63, 66, 67,
- 0, 230, 130, 226, 95, 90, 92, 0, 211, 113,
- 0, 157, 174, 0, 220, 221, 93, 0, 0, 0,
- 121, 127, 0, 0, 0, 191, 192, 193, 245, 125,
- 0, 190, 194, 228, 188, 0, 119, 0, 181, 0,
- 182, 0, 14, 16, 28, 88, 16, 16, 33, 0,
- 0, 77, 0, 0, 79, 0, 0, 232, 16, 75,
- 80, 0, 0, 61, 48, 0, 0, 0, 111, 0,
- 0, 115, 0, 0, 91, 159, 107, 172, 131, 0,
- 124, 167, 0, 120, 126, 0, 122, 183, 184, 118,
- 0, 90, 0, 53, 226, 73, 73, 0, 0, 0,
- 0, 0, 43, 0, 0, 0, 0, 231, 213, 96,
- 19, 129, 123, 108, 0, 0, 90, 19, 0, 0,
- 0, 18, 68, 68, 0, 0, 71, 76, 0, 0,
- 38, 39, 0, 21, 98, 97, 30, 0, 0, 35,
- 71, 71, 19, 0, 0, 36, 37, 0, 0, 51,
- 0, 0, 71, 160, 0, 19, 54, 41, 42, 0,
- 69, 0, 71, 71, 44, 0, 47, 58, 0, 22,
- 0, 17, 0, 46, 50, 73, 71, 19, 57, 15,
- 32, 0, 0, 49, 0, 68, 0, 59, 70, 0,
- 45
+ 0, 246, 146, 242, 111, 90, 92, 0, 227, 129,
+ 0, 173, 190, 0, 236, 237, 93, 0, 0, 0,
+ 137, 143, 0, 0, 0, 207, 208, 209, 261, 141,
+ 0, 206, 210, 244, 204, 0, 135, 0, 197, 0,
+ 198, 0, 14, 16, 28, 88, 16, 16, 33, 0,
+ 0, 77, 0, 0, 79, 0, 0, 248, 16, 75,
+ 80, 0, 0, 61, 48, 0, 0, 0, 127, 0,
+ 0, 131, 109, 0, 91, 175, 123, 188, 147, 0,
+ 140, 183, 0, 136, 142, 0, 138, 199, 200, 134,
+ 0, 90, 0, 53, 242, 73, 73, 0, 0, 0,
+ 0, 0, 43, 0, 0, 0, 0, 247, 229, 97,
+ 98, 95, 95, 105, 104, 108, 110, 0, 19, 145,
+ 139, 124, 0, 0, 90, 19, 0, 0, 0, 18,
+ 68, 68, 0, 0, 71, 76, 0, 0, 38, 39,
+ 96, 100, 100, 106, 112, 0, 21, 114, 113, 30,
+ 0, 0, 35, 71, 71, 19, 0, 0, 36, 37,
+ 0, 0, 51, 0, 0, 71, 101, 103, 99, 107,
+ 176, 0, 19, 54, 41, 42, 0, 69, 0, 71,
+ 71, 44, 0, 47, 102, 58, 0, 22, 0, 17,
+ 0, 46, 50, 73, 71, 19, 57, 15, 32, 0,
+ 0, 49, 0, 68, 0, 59, 70, 0, 45
};
/* YYPGOTO[NTERM-NUM]. */
static const yytype_int16 yypgoto[] =
{
- -412, -412, -412, -412, -412, -412, -412, -412, 3, -412,
- -60, -37, -412, -15, -412, 490, 410, 10, -412, -412,
- -412, -412, -412, -412, -412, -412, -412, -315, -399, -75,
- -411, -412, 53, 204, -234, 19, -412, 318, 499, -412,
- 456, 165, -329, 305, 134, -412, -412, -6, -36, -412,
- -412, -412, -412, -412, -412, -412, -412, 198, -412, -412,
- 415, -106, -125, -412, -412, 241, -412, -412, 357, 303,
- -41, -39, -412, -412, -412, -412, -412, 9
+ -440, -440, -440, -440, -440, -440, -440, -440, 10, -440,
+ -60, -95, -440, -15, -440, 529, 454, -3, -440, -440,
+ -440, -440, -440, -440, -440, -440, -440, -315, -439, -103,
+ -420, -440, 88, 282, -206, 26, -440, 361, 522, -440,
+ 506, 200, -330, 353, 156, -440, -440, 136, -440, 133,
+ -440, -440, 177, -440, -440, -6, -36, -440, -440, -440,
+ -440, -440, -440, -440, -440, 25, -440, -440, 468, -106,
+ -125, -440, -440, 306, -440, -440, 450, 233, -35, -33,
+ -440, -440, -440, -440, -440, 4
};
/* YYDEFGOTO[NTERM-NUM]. */
static const yytype_int16 yydefgoto[] =
{
-1, 7, 8, 9, 10, 11, 12, 13, 94, 374,
- 15, 452, 472, 102, 484, 222, 100, 101, 375, 376,
- 303, 457, 505, 433, 447, 499, 508, 96, 475, 212,
- 449, 390, 380, 324, 383, 392, 300, 198, 121, 195,
- 141, 232, 337, 251, 335, 402, 466, 97, 58, 59,
- 333, 287, 60, 61, 62, 63, 64, 65, 117, 66,
- 145, 131, 67, 400, 386, 311, 312, 206, 68, 69,
- 70, 71, 72, 73, 74, 75, 76, 158
+ 15, 460, 485, 102, 501, 222, 100, 101, 375, 376,
+ 303, 465, 523, 433, 455, 517, 526, 96, 488, 212,
+ 457, 390, 380, 324, 383, 392, 300, 198, 121, 195,
+ 141, 232, 337, 251, 471, 442, 443, 497, 444, 445,
+ 446, 447, 335, 402, 479, 97, 58, 59, 333, 287,
+ 60, 61, 62, 63, 64, 65, 117, 66, 145, 131,
+ 67, 400, 386, 311, 312, 206, 68, 69, 70, 71,
+ 72, 73, 74, 75, 76, 158
};
/* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If
number is the opposite. If YYTABLE_NINF, syntax error. */
static const yytype_int16 yytable[] =
{
- 103, 236, 389, 57, 130, 147, 403, 148, 14, 224,
- 105, 377, 150, 78, 77, 450, 164, 194, 165, 230,
- 77, 95, 110, 110, 110, 77, 110, 110, 112, 113,
- 114, 108, 115, 116, 119, 241, 109, 138, 19, 20,
- 77, 252, 127, 110, 110, 135, 124, 163, 157, 133,
- 134, 108, 497, 348, 476, 139, 109, 118, 110, 110,
- 140, 187, 231, 188, 163, 159, -247, -249, -247, -249,
- 19, 20, 21, 385, 399, 473, 474, 19, 20, 130,
- 125, 126, 187, 391, 188, -251, 396, 397, -247, 223,
- -247, -249, 445, -249, 512, 210, -16, 238, 186, -222,
- 330, 193, 246, 378, 247, 130, 464, 166, 221, 332,
- 197, -221, 227, 55, 361, 350, 518, 467, 199, 235,
- 57, -223, 310, 211, 229, 55, -225, -224, 200, 110,
- 498, 366, 189, 55, 190, 237, 201, 368, 249, 304,
- 305, 306, 307, 309, 370, 317, 318, 202, 320, 321,
- 160, 161, 162, 143, 254, 255, 256, 55, 258, 259,
- 261, 434, 144, 315, 55, 316, -252, -252, -252, 185,
- 160, 161, 162, 160, 161, 162, 160, 161, 162, 298,
- 290, 291, 292, 293, 294, 295, 296, 297, 208, 191,
- 331, 192, 160, 161, 162, 454, 455, 389, 160, 161,
- 162, 240, 408, 213, 209, 160, 161, 162, 323, 325,
- 326, 327, 328, 329, 322, 106, 107, 225, 226, 57,
- 413, 228, 239, 441, 481, 233, 250, 401, 120, 299,
- 252, 340, 123, 302, 203, 308, 343, 128, 415, 319,
- 136, 334, 336, 142, 339, 149, 347, 151, 152, 153,
- 154, 155, 341, 346, 277, 348, 278, 502, 204, 395,
- 279, 280, 281, 160, 161, 162, 282, 205, 162, 55,
- 373, 353, 354, 355, 160, 161, 162, 315, 360, 316,
- 356, 160, 161, 162, 160, 161, 162, 357, 110, 358,
- 362, 160, 161, 162, 160, 161, 162, 130, 381, 325,
- 384, 384, 349, 214, 215, 216, 217, 283, 379, 55,
- 218, 393, 219, 420, 384, 384, 422, 423, 448, 365,
- 253, 398, 111, 111, 111, 363, 111, 111, 430, 160,
- 161, 162, 160, 161, 162, -31, 388, 160, 161, 162,
- 405, 243, 409, 132, 111, 284, 404, 285, 286, 146,
- 410, 230, 160, 161, 162, 338, 424, 57, 111, 111,
- 367, 257, 416, -79, 417, 262, 263, 264, 265, 266,
- 267, 268, 269, 270, 271, 272, 273, 274, 275, 276,
- 369, 479, 160, 161, 162, 160, 161, 162, 130, 384,
- 418, 453, 207, 437, 456, 487, 488, 419, 460, 461,
- 425, 426, 160, 161, 162, 427, 428, 496, 429, 431,
- 371, 345, 470, 471, 160, 161, 162, 503, 504, 160,
- 161, 162, 482, 384, 384, 462, 432, 170, 171, 132,
- 412, 513, 468, 435, 436, 440, 490, 438, -175, 442,
- 492, 493, 439, 443, 451, 351, 245, 187, 465, 188,
- -175, 381, 384, 179, 180, 459, 444, 489, 506, 181,
- 458, 463, 182, 183, 184, 185, 168, 169, 170, 171,
- 500, 469, 477, 478, 515, 485, 491, -175, -175, -175,
- -175, 507, 520, 494, -175, 384, -175, 495, 288, -175,
- 509, 511, 514, 178, 179, 180, -175, -175, -175, -175,
- 181, 519, 99, 182, 183, 184, 185, 314, 220, 382,
- 480, -175, -175, -175, 301, -175, -175, -175, -175, -175,
- -175, -175, -175, -175, -175, -175, 168, 169, 170, 171,
- -175, 516, 122, -175, -175, -175, -175, -175, 196, -175,
- 421, -252, -175, 170, 171, -214, 160, 161, 162, 344,
- 411, 176, 177, 178, 179, 180, 446, -214, 244, 394,
- 181, 313, 170, 182, 183, 184, 185, 0, 0, 179,
- 180, 0, 364, 0, 0, 181, 0, 0, 182, 183,
- 184, 185, 0, 0, -214, -214, -214, -214, 111, 180,
- 0, -214, 0, -214, 181, 0, -214, 182, 183, 184,
- 185, 0, 0, -214, -214, -214, -214, 160, 161, 162,
- 0, 0, 387, 160, 161, 162, 0, 0, -214, -214,
- -214, 314, -214, -214, -214, -214, -214, -214, -214, -214,
- -214, -214, -214, 406, 0, 0, 0, -214, 0, 407,
- -214, -214, -214, -214, -214, 0, -214, -13, 79, -214,
- 0, 0, 0, 0, 0, 0, 77, 0, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 80,
- 98, 81, 82, 33, 83, 84, 85, 86, 87, 88,
- 170, 171, 0, 89, 90, 91, 92, 34, 0, 35,
- 36, 37, 38, 39, 40, 160, 161, 162, 0, 41,
- 42, 43, 44, 45, 46, 47, 0, 180, 0, 0,
- 0, 0, 181, 48, 0, 182, 183, 184, 185, 0,
- 0, 414, 0, 0, 0, 49, 50, 0, 51, 0,
- 52, 53, -3, 79, 0, 0, 0, 54, 93, 55,
- 56, 77, 0, 16, 0, 17, 18, 19, 20, 21,
- 0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
- 29, 30, 31, 32, 80, 98, 81, 82, 33, 83,
- 84, 85, 86, 87, 88, 0, 0, 0, 89, 90,
- 91, 92, 34, 0, 35, 36, 37, 38, 39, 40,
- 0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
- 47, 180, 0, 0, 0, 0, 181, 0, 48, 182,
- 183, 184, 185, 181, 0, 0, 182, 183, 184, 185,
- 49, 50, 0, 51, 0, 52, 53, 0, 79, 0,
- 0, 0, 54, 93, 55, 56, 77, 372, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 80,
- 98, 81, 82, 33, 83, 84, 85, 86, 87, 88,
- 0, 0, 0, 89, 90, 91, 92, 34, 0, 35,
- 36, 37, 38, 39, 40, 0, 0, 0, 0, 41,
- 42, 43, 44, 45, 46, 47, 1, 2, 3, 4,
- 5, 6, 0, 48, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 49, 50, 0, 51, 0,
- 52, 53, 0, 79, 0, 0, 0, 54, 93, 55,
- 56, 77, 483, 16, 0, 17, 18, 19, 20, 21,
- 0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
- 29, 30, 31, 32, 80, 98, 81, 82, 33, 83,
- 84, 85, 86, 87, 88, 0, 0, 0, 89, 90,
- 91, 92, 34, 0, 35, 36, 37, 38, 39, 40,
- 0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
- 47, 0, 0, 0, 0, 0, 0, 0, 48, 0,
+ 103, 236, 389, 57, 130, 403, 458, 377, 95, 224,
+ 105, 147, 150, 148, 77, 230, 164, 194, 165, 118,
+ 78, 14, 489, 112, 113, 114, 515, 115, 116, 110,
+ 110, 110, 119, 110, 110, 241, 139, 138, 19, 20,
+ 21, 140, 106, 107, 133, 134, 19, 20, 157, 127,
+ 110, 110, 135, 77, 124, 120, 187, 77, 188, 123,
+ 159, -263, 231, -263, 128, 110, 110, 136, 108, 77,
+ 142, 125, 149, 109, 151, 152, 153, 154, 155, 130,
+ 108, 277, 126, 278, -265, 109, -265, 279, 280, 281,
+ 310, 453, -16, 282, 536, 221, 163, 238, -267, 378,
+ 330, 385, 210, 530, 516, 130, 477, 166, 246, 252,
+ 247, 391, 227, 163, 396, 397, -239, 186, 348, 235,
+ 57, -241, 193, 399, 480, 55, 197, 439, 440, 199,
+ 237, 229, 200, 55, 283, 187, 110, 188, 249, 304,
+ 305, 306, 307, 309, -240, 317, 318, 211, 320, 321,
+ 55, 361, 19, 20, 254, 255, 256, 201, 258, 259,
+ 261, 202, 55, 160, 161, 162, 208, -238, 243, 315,
+ 209, 316, 284, 225, 285, 286, -237, 486, 487, 298,
+ 290, 291, 292, 293, 294, 295, 296, 297, 257, 434,
+ 331, 240, 262, 263, 264, 265, 266, 267, 268, 269,
+ 270, 271, 272, 273, 274, 275, 276, 223, 323, 325,
+ 326, 327, 328, 329, 441, 389, 203, 213, -263, 57,
+ -263, 322, 226, 462, 463, 239, 228, 401, 143, 332,
+ -265, 340, -265, 160, 161, 162, 343, 144, 415, 55,
+ 204, 233, 350, 160, 161, 162, 347, 366, 189, 205,
+ 190, 55, 111, 111, 111, 250, 111, 111, 368, 395,
+ 494, 349, 370, 252, 299, 160, 161, 162, 160, 161,
+ 162, 353, 354, 132, 111, 191, 408, 192, 360, 146,
+ 302, 308, 413, 315, 319, 316, 339, 449, 111, 111,
+ 160, 161, 162, 365, 334, 110, 336, 130, 381, 325,
+ 384, 384, 520, 160, 161, 162, 341, 346, 160, 161,
+ 162, 393, 348, 420, 384, 384, 422, 423, 456, 160,
+ 161, 162, 207, 160, 161, 162, 162, 355, 430, 160,
+ 161, 162, 356, 461, 357, 358, 464, 160, 161, 162,
+ 468, 469, 409, 160, 161, 162, 362, 405, 160, 161,
+ 162, 214, 215, 216, 217, 253, 373, 57, 218, 132,
+ 219, 492, 483, 484, 214, 215, 216, 217, 160, 161,
+ 162, 218, 495, 219, 363, 379, 245, 411, 170, 171,
+ 504, 505, 160, 161, 162, 160, 161, 162, 130, 384,
+ -31, 507, 513, 437, 338, 509, 510, 388, 160, 161,
+ 162, 55, 398, 404, 179, 180, 521, 522, 345, 230,
+ 181, -79, 410, 182, 183, 184, 185, 524, 288, 416,
+ 167, 531, 417, 384, 384, 418, 419, 168, 169, 170,
+ 171, 424, 425, 475, 533, 426, 427, 314, 428, 431,
+ 481, 429, 538, 160, 161, 162, 432, 172, 173, 352,
+ 174, 175, 176, 177, 178, 179, 180, 435, 436, 381,
+ 384, 181, 438, 478, 182, 183, 184, 185, 448, 452,
+ 506, 367, 160, 161, 162, 450, 451, 168, 169, 170,
+ 171, 160, 161, 162, 466, -191, 459, 518, 467, 470,
+ 473, 160, 161, 162, 187, 474, 188, -191, 476, 482,
+ 369, 496, 384, 177, 178, 179, 180, 508, 502, 371,
+ 532, 181, 527, 490, 182, 183, 184, 185, 111, 412,
+ 491, 514, 525, 511, -191, -191, -191, -191, 160, 161,
+ 162, -191, 512, -191, 181, 529, -191, 182, 183, 184,
+ 185, 99, 387, -191, -191, -191, -191, 537, 160, 161,
+ 162, 314, 220, 493, 351, 122, 534, 301, -191, -191,
+ -191, -230, -191, -191, -191, -191, -191, -191, -191, -191,
+ -191, -191, -191, -230, 364, 421, -268, -191, 170, 171,
+ -191, -191, -191, -191, -191, 180, -191, 382, 196, -191,
+ 181, 170, 171, 182, 183, 184, 185, 344, 472, 454,
+ -230, -230, -230, -230, 179, 180, 499, -230, 498, -230,
+ 181, 244, -230, 182, 183, 184, 185, 0, 180, -230,
+ -230, -230, -230, 181, 394, 0, 182, 183, 184, 185,
+ -268, -268, -268, 185, -230, -230, -230, 0, -230, -230,
+ -230, -230, -230, -230, -230, -230, -230, -230, -230, 160,
+ 161, 162, 0, -230, 313, 0, -230, -230, -230, -230,
+ -230, 0, -230, -13, 79, -230, 0, 0, 0, 0,
+ 0, 0, 77, 0, 16, 406, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 170, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
+ 40, 160, 161, 162, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 180, 160, 161, 162, 0, 181, 48,
+ 0, 182, 183, 184, 185, 0, 0, 407, 0, 0,
+ 0, 49, 50, 0, 51, 0, 52, 53, -3, 79,
+ 414, 0, 0, 54, 93, 55, 56, 77, 0, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 98, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 1, 2, 3,
+ 4, 5, 6, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 79, 0, 0, 0, 54, 93,
+ 55, 56, 77, 372, 16, 0, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 0, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
+ 40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 49, 50, 0, 51, 0, 52, 53, 0, 79, 0,
- 0, 0, 54, 93, 55, 56, 77, 486, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 80,
- 98, 81, 82, 33, 83, 84, 85, 86, 87, 88,
- 0, 0, 0, 89, 90, 91, 92, 34, 0, 35,
- 36, 37, 38, 39, 40, 0, 0, 0, 0, 41,
- 42, 43, 44, 45, 46, 47, 0, 0, 0, 0,
- 0, 0, 0, 48, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 49, 50, 0, 51, 0,
- 52, 53, 0, 79, 0, 0, 0, 54, 93, 55,
- 56, 77, 501, 16, 0, 17, 18, 19, 20, 21,
- 0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
- 29, 30, 31, 32, 80, 98, 81, 82, 33, 83,
- 84, 85, 86, 87, 88, 0, 0, 0, 89, 90,
- 91, 92, 34, 0, 35, 36, 37, 38, 39, 40,
- 0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
- 47, 0, 0, 0, 0, 0, 0, 0, 48, 0,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 79,
+ 0, 0, 0, 54, 93, 55, 56, 77, 500, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 98, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 0, 0, 0,
+ 0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 79, 0, 0, 0, 54, 93,
+ 55, 56, 77, 503, 16, 0, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 0, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
+ 40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 49, 50, 0, 51, 0, 52, 53, 0, 79, 0,
- 0, 0, 54, 93, 55, 56, 77, 510, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 80,
- 98, 81, 82, 33, 83, 84, 85, 86, 87, 88,
- 0, 0, 0, 89, 90, 91, 92, 34, 0, 35,
- 36, 37, 38, 39, 40, 0, 0, 0, 0, 41,
- 42, 43, 44, 45, 46, 47, 0, 0, 0, 0,
- 0, 0, 0, 48, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 49, 50, 0, 51, 0,
- 52, 53, 0, 79, 0, 0, 0, 54, 93, 55,
- 56, 77, 0, 16, 0, 17, 18, 19, 20, 21,
- 0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
- 29, 30, 31, 32, 80, 98, 81, 82, 33, 83,
- 84, 85, 86, 87, 88, 0, 0, 0, 89, 90,
- 91, 92, 34, 0, 35, 36, 37, 38, 39, 40,
- 0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
- 47, 0, 0, 517, 0, 0, 0, 0, 48, 0,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 79,
+ 0, 0, 0, 54, 93, 55, 56, 77, 519, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 98, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 0, 0, 0,
+ 0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 79, 0, 0, 0, 54, 93,
+ 55, 56, 77, 528, 16, 0, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 0, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
+ 40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 49, 50, 0, 51, 0, 52, 53, 0, 79, 0,
- 0, 0, 54, 93, 55, 56, 77, 0, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 80,
- 98, 81, 82, 33, 83, 84, 85, 86, 87, 88,
- 0, 0, 0, 89, 90, 91, 92, 34, 0, 35,
- 36, 37, 38, 39, 40, 0, 0, 0, 0, 41,
- 42, 43, 44, 45, 46, 47, 0, 0, 0, 0,
- 0, 0, 0, 48, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 49, 50, 0, 51, 0,
- 52, 53, 0, 79, 0, 0, 0, 54, 93, 55,
- 56, 77, 0, 16, 0, 17, 18, 19, 20, 21,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 79,
+ 0, 0, 0, 54, 93, 55, 56, 77, 0, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 98, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 0, 0, 535,
+ 0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 79, 0, 0, 0, 54, 93,
+ 55, 56, 77, 0, 16, 0, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 0, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
+ 40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 79,
+ 0, 0, 0, 54, 93, 55, 56, 77, 0, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 0, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 0, 0, 0,
+ 0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 79, 0, 0, 0, 0, 54, 93,
+ 55, 56, 0, 16, 0, 17, 18, 19, 20, 21,
0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
- 29, 30, 31, 32, 80, 0, 81, 82, 33, 83,
- 84, 85, 86, 87, 88, 0, 0, 0, 89, 90,
- 91, 92, 34, 0, 35, 36, 37, 38, 39, 40,
+ 29, 30, 31, 32, 0, 0, 0, 0, 33, 0,
+ 0, -268, 0, 0, 0, 0, 0, 0, 168, 169,
+ 170, 171, 34, 0, 35, 36, 37, 38, 39, 40,
0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
- 47, 0, 0, 0, 0, 0, 0, 0, 48, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 47, 174, 175, 176, 177, 178, 179, 180, 48, 0,
+ 0, 0, 181, 0, 0, 182, 183, 184, 185, 0,
49, 50, 0, 51, 0, 52, 53, 79, 0, 0,
- 0, 0, 54, 93, 55, 56, 0, 16, 0, 17,
+ 0, 0, 54, -74, 55, 56, 0, 16, 0, 17,
18, 19, 20, 21, 0, 0, 22, 23, 24, 25,
26, 0, 27, 28, 29, 30, 31, 32, 0, 0,
- 0, 0, 33, 0, 0, -252, 0, 0, 0, 0,
- 0, 0, 168, 169, 170, 171, 34, 0, 35, 36,
+ 0, 0, 33, 0, 0, 0, 0, 0, 0, 0,
+ 168, 169, 170, 171, 0, 0, 34, 0, 35, 36,
37, 38, 39, 40, 0, 0, 0, 0, 41, 42,
- 43, 44, 45, 46, 47, 174, 175, 176, 177, 178,
- 179, 180, 48, 0, 0, 0, 181, 0, 0, 182,
- 183, 184, 185, 0, 49, 50, 0, 51, 0, 52,
- 53, 79, 0, 0, 0, 0, 54, -74, 55, 56,
- 0, 16, 0, 17, 18, 19, 20, 21, 0, 0,
- 22, 23, 24, 25, 26, 0, 27, 28, 29, 30,
- 31, 32, 0, 0, 0, 0, 33, 0, 0, 0,
- 0, 0, 0, 168, 169, 170, 171, 0, 0, 0,
- 34, 0, 35, 36, 37, 38, 39, 40, 0, 0,
- 0, 0, 41, 42, 43, 44, 45, 46, 47, 177,
- 178, 179, 180, 0, 0, 0, 48, 181, 0, 0,
- 182, 183, 184, 185, 0, 0, 0, 0, 49, 50,
- 0, 51, 0, 52, 53, 0, 0, 0, 0, -74,
- 54, 0, 55, 56, 77, 0, 16, 0, 17, 18,
- 19, 20, 21, 0, 0, 129, 23, 24, 25, 26,
- 109, 27, 28, 29, 30, 31, 32, 0, 0, 0,
- 0, 33, 0, 0, 0, 0, 168, -252, 170, 171,
- 0, 0, 0, 0, 0, 34, 0, 35, 36, 37,
- 38, 39, 40, 0, 0, 0, 0, 41, 42, 43,
- 44, 45, 46, 47, 179, 180, 0, 0, 0, 0,
- 181, 48, 0, 182, 183, 184, 185, 0, 0, 0,
- 0, 0, 0, 49, 50, 0, 51, 0, 52, 53,
- 0, 0, 0, 0, 0, 54, 0, 55, 56, 77,
- 0, 16, 0, 17, 18, 19, 20, 21, 0, 0,
- 22, 23, 24, 25, 26, 0, 27, 28, 29, 30,
- 31, 32, 0, 0, 0, 0, 33, 0, 0, 0,
- 0, 168, 169, 170, 171, 0, 0, 0, 0, 0,
- 34, 0, 35, 36, 37, 38, 39, 40, 0, 0,
- 0, 0, 41, 42, 43, 44, 45, 46, 47, 179,
- 180, 0, 0, 0, 0, 181, 48, 0, 182, 183,
- 184, 185, 0, 0, 0, 0, 0, 0, 49, 50,
- 0, 51, 0, 52, 53, 0, 0, 0, 0, 0,
- 54, 0, 55, 56, 16, 104, 17, 18, 19, 20,
- 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
- 28, 29, 30, 31, 32, 0, 0, 0, 0, 33,
- 214, 215, 216, 217, 0, 0, 0, 218, 0, 219,
- 0, 0, 0, 34, 0, 35, 36, 37, 38, 39,
- 40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
- 46, 47, 0, 0, 160, 161, 162, 0, 0, 48,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 49, 50, 0, 51, 0, 52, 53, 0, 0,
- 0, 0, 0, 54, 0, 55, 56, 16, 0, 17,
+ 43, 44, 45, 46, 47, 176, 177, 178, 179, 180,
+ 0, 0, 48, 0, 181, 0, 0, 182, 183, 184,
+ 185, 0, 0, 0, 49, 50, 0, 51, 0, 52,
+ 53, 0, 0, 0, 0, -74, 54, 0, 55, 56,
+ 77, 0, 16, 0, 17, 18, 19, 20, 21, 0,
+ 0, 129, 23, 24, 25, 26, 109, 27, 28, 29,
+ 30, 31, 32, 0, 0, 0, 0, 33, 0, 0,
+ 0, 0, 0, 0, 168, 169, 170, 171, 0, 0,
+ 0, 34, 0, 35, 36, 37, 38, 39, 40, 0,
+ 0, 0, 0, 41, 42, 43, 44, 45, 46, 47,
+ 0, 178, 179, 180, 0, 0, 0, 48, 181, 0,
+ 0, 182, 183, 184, 185, 0, 0, 0, 0, 49,
+ 50, 0, 51, 0, 52, 53, 0, 0, 0, 0,
+ 0, 54, 0, 55, 56, 77, 0, 16, 0, 17,
18, 19, 20, 21, 0, 0, 22, 23, 24, 25,
26, 0, 27, 28, 29, 30, 31, 32, 0, 0,
- 0, 0, 33, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 34, 0, 35, 36,
+ 0, 0, 33, 0, 0, 0, 0, 168, -268, 170,
+ 171, 0, 0, 0, 0, 0, 34, 0, 35, 36,
37, 38, 39, 40, 0, 0, 0, 0, 41, 42,
- 43, 44, 45, 46, 47, 0, 0, 0, 0, 0,
- 0, 0, 48, 0, 0, 0, 0, 0, 0, 0,
+ 43, 44, 45, 46, 47, 179, 180, 0, 0, 0,
+ 0, 181, 48, 0, 182, 183, 184, 185, 0, 0,
0, 0, 0, 0, 49, 50, 0, 51, 0, 52,
- 53, 0, 0, 0, 0, 0, 54, 137, 55, 56,
- 16, 0, 17, 18, 19, 20, 21, 0, 0, 22,
+ 53, 0, 0, 0, 0, 0, 54, 0, 55, 56,
+ 16, 104, 17, 18, 19, 20, 21, 0, 0, 22,
23, 24, 25, 26, 0, 27, 28, 29, 30, 31,
32, 0, 0, 0, 0, 33, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 34,
+ 168, 169, 170, 171, 0, 0, 0, 0, 0, 34,
0, 35, 36, 37, 38, 39, 40, 0, 0, 0,
- 0, 41, 42, 43, 44, 45, 46, 47, 0, 0,
- 0, 0, 0, 0, 0, 48, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 49, 50, 0,
- 51, 0, 52, 53, 0, 0, 0, 0, 156, 54,
+ 0, 41, 42, 43, 44, 45, 46, 47, 179, 180,
+ 0, 0, 0, 0, 181, 48, 0, 182, 183, 184,
+ 185, 0, 0, 0, 0, 0, 0, 49, 50, 0,
+ 51, 0, 52, 53, 0, 0, 0, 0, 0, 54,
0, 55, 56, 16, 0, 17, 18, 19, 20, 21,
0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
29, 30, 31, 32, 0, 0, 0, 0, 33, 0,
47, 0, 0, 0, 0, 0, 0, 0, 48, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
49, 50, 0, 51, 0, 52, 53, 0, 0, 0,
- 0, 234, 54, 0, 55, 56, 16, 0, 17, 18,
+ 0, 0, 54, 137, 55, 56, 16, 0, 17, 18,
19, 20, 21, 0, 0, 22, 23, 24, 25, 26,
0, 27, 28, 29, 30, 31, 32, 0, 0, 0,
0, 33, 0, 0, 0, 0, 0, 0, 0, 0,
44, 45, 46, 47, 0, 0, 0, 0, 0, 0,
0, 48, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 49, 50, 0, 51, 0, 52, 53,
- 0, 0, 0, 0, 248, 54, 0, 55, 56, 16,
+ 0, 0, 0, 0, 156, 54, 0, 55, 56, 16,
0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
0, 0, 0, 0, 33, 0, 0, 0, 0, 0,
41, 42, 43, 44, 45, 46, 47, 0, 0, 0,
0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
- 0, 52, 53, 0, 0, 0, 0, 260, 54, 0,
+ 0, 52, 53, 0, 0, 0, 0, 234, 54, 0,
55, 56, 16, 0, 17, 18, 19, 20, 21, 0,
0, 22, 23, 24, 25, 26, 0, 27, 28, 29,
30, 31, 32, 0, 0, 0, 0, 33, 0, 0,
0, 0, 0, 0, 0, 0, 0, 48, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 49,
50, 0, 51, 0, 52, 53, 0, 0, 0, 0,
- 289, 54, 0, 55, 56, 16, 0, 17, 18, 19,
+ 248, 54, 0, 55, 56, 16, 0, 17, 18, 19,
20, 21, 0, 0, 22, 23, 24, 25, 26, 0,
27, 28, 29, 30, 31, 32, 0, 0, 0, 0,
33, 0, 0, 0, 0, 0, 0, 0, 0, 0,
45, 46, 47, 0, 0, 0, 0, 0, 0, 0,
48, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 49, 50, 0, 51, 0, 52, 53, 0,
- 0, 0, 0, 342, 54, 0, 55, 56, 16, 0,
+ 0, 0, 0, 260, 54, 0, 55, 56, 16, 0,
17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
25, 26, 0, 27, 28, 29, 30, 31, 32, 0,
0, 0, 0, 33, 0, 0, 0, 0, 0, 0,
42, 43, 44, 45, 46, 47, 0, 0, 0, 0,
0, 0, 0, 48, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 49, 50, 0, 51, 0,
- 52, 53, 0, 0, 0, 0, 359, 54, 0, 55,
+ 52, 53, 0, 0, 0, 0, 289, 54, 0, 55,
56, 16, 0, 17, 18, 19, 20, 21, 0, 0,
22, 23, 24, 25, 26, 0, 27, 28, 29, 30,
31, 32, 0, 0, 0, 0, 33, 0, 0, 0,
0, 0, 41, 42, 43, 44, 45, 46, 47, 0,
0, 0, 0, 0, 0, 0, 48, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 49, 50,
- 0, 51, 0, 52, 53, 0, 0, 0, 0, 0,
+ 0, 51, 0, 52, 53, 0, 0, 0, 0, 342,
54, 0, 55, 56, 16, 0, 17, 18, 19, 20,
21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
28, 29, 30, 31, 32, 0, 0, 0, 0, 33,
0, 0, 0, 34, 0, 35, 36, 37, 38, 39,
40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
- 167, 0, 0, 0, 0, 0, 0, 168, 169, 170,
- 171, 49, 50, 0, 51, 0, 52, 53, 0, 0,
- 0, 0, 0, 242, 0, 55, 56, 172, 173, 352,
- 174, 175, 176, 177, 178, 179, 180, 0, 0, 0,
- 0, 181, 167, 0, 182, 183, 184, 185, 0, 168,
- 169, 170, 171, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 172,
- 173, 0, 174, 175, 176, 177, 178, 179, 180, 0,
- 0, 0, 0, 181, 167, 0, 182, 183, 184, 185,
- 0, 168, 169, 170, 171, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 173, 0, 174, 175, 176, 177, 178, 179,
- 180, 0, 0, 0, 0, 181, 0, 0, 182, 183,
- 184, 185
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 0,
+ 0, 0, 359, 54, 0, 55, 56, 16, 0, 17,
+ 18, 19, 20, 21, 0, 0, 22, 23, 24, 25,
+ 26, 0, 27, 28, 29, 30, 31, 32, 0, 0,
+ 0, 0, 33, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 34, 0, 35, 36,
+ 37, 38, 39, 40, 0, 0, 0, 0, 41, 42,
+ 43, 44, 45, 46, 47, 0, 0, 0, 0, 0,
+ 0, 0, 48, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 49, 50, 0, 51, 0, 52,
+ 53, 0, 0, 0, 0, 0, 54, 0, 55, 56,
+ 16, 0, 17, 18, 19, 20, 21, 0, 0, 22,
+ 23, 24, 25, 26, 0, 27, 28, 29, 30, 31,
+ 32, 0, 0, 0, 0, 33, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 34,
+ 0, 35, 36, 37, 38, 39, 40, 0, 0, 0,
+ 0, 41, 42, 43, 44, 45, 46, 47, 0, 0,
+ 0, 0, 0, 0, 0, 48, 167, 0, 0, 0,
+ 0, 0, 0, 168, 169, 170, 171, 49, 50, 0,
+ 51, 0, 52, 53, 0, 0, 0, 0, 0, 242,
+ 0, 55, 56, 172, 173, 0, 174, 175, 176, 177,
+ 178, 179, 180, 0, 0, 0, 0, 181, 167, 0,
+ 182, 183, 184, 185, 0, 168, 169, 170, 171, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 173, 0, 174, 175,
+ 176, 177, 178, 179, 180, 0, 0, 0, 0, 181,
+ 0, 0, 182, 183, 184, 185
};
static const yytype_int16 yycheck[] =
{
- 15, 126, 317, 9, 40, 46, 335, 46, 0, 115,
- 16, 9, 48, 10, 9, 426, 9, 77, 11, 23,
- 9, 11, 19, 20, 21, 9, 23, 24, 19, 20,
- 21, 20, 23, 24, 100, 141, 25, 43, 15, 16,
- 9, 11, 39, 40, 41, 42, 100, 77, 54, 40,
- 41, 20, 23, 11, 453, 20, 25, 11, 55, 56,
- 25, 9, 122, 11, 77, 56, 9, 9, 11, 11,
- 15, 16, 17, 307, 104, 43, 44, 15, 16, 115,
- 100, 100, 9, 317, 11, 9, 320, 321, 9, 12,
- 11, 9, 421, 11, 505, 92, 100, 133, 100, 69,
- 225, 9, 143, 101, 143, 141, 101, 100, 98, 12,
- 20, 69, 118, 102, 103, 12, 515, 446, 100, 125,
- 126, 69, 67, 45, 121, 102, 69, 69, 100, 126,
- 101, 12, 9, 102, 11, 126, 100, 12, 144, 199,
- 200, 201, 202, 203, 12, 205, 206, 100, 208, 209,
- 73, 74, 75, 91, 160, 161, 162, 102, 164, 165,
- 166, 395, 100, 204, 102, 204, 95, 96, 97, 98,
- 73, 74, 75, 73, 74, 75, 73, 74, 75, 194,
- 186, 187, 188, 189, 190, 191, 192, 193, 100, 9,
- 226, 11, 73, 74, 75, 429, 430, 512, 73, 74,
- 75, 101, 12, 101, 100, 73, 74, 75, 214, 215,
- 216, 217, 218, 219, 211, 17, 18, 100, 100, 225,
- 12, 99, 10, 12, 458, 99, 69, 333, 30, 20,
- 11, 237, 34, 20, 67, 91, 242, 39, 363, 100,
- 42, 100, 69, 45, 99, 47, 252, 49, 50, 51,
- 52, 53, 10, 23, 9, 11, 11, 491, 91, 319,
- 15, 16, 17, 73, 74, 75, 21, 100, 75, 102,
- 18, 277, 278, 103, 73, 74, 75, 318, 284, 318,
- 103, 73, 74, 75, 73, 74, 75, 103, 285, 103,
- 103, 73, 74, 75, 73, 74, 75, 333, 304, 305,
- 306, 307, 101, 39, 40, 41, 42, 62, 20, 102,
- 46, 317, 48, 373, 320, 321, 376, 377, 424, 101,
- 99, 99, 19, 20, 21, 100, 23, 24, 388, 73,
- 74, 75, 73, 74, 75, 100, 100, 73, 74, 75,
- 337, 143, 348, 40, 41, 100, 23, 102, 103, 46,
- 10, 23, 73, 74, 75, 99, 20, 363, 55, 56,
- 101, 163, 10, 99, 10, 167, 168, 169, 170, 171,
- 172, 173, 174, 175, 176, 177, 178, 179, 180, 181,
- 101, 456, 73, 74, 75, 73, 74, 75, 424, 395,
- 10, 428, 89, 399, 431, 470, 471, 10, 435, 436,
- 99, 99, 73, 74, 75, 99, 99, 482, 100, 99,
- 101, 99, 449, 450, 73, 74, 75, 492, 493, 73,
- 74, 75, 459, 429, 430, 440, 101, 60, 61, 126,
- 101, 506, 447, 99, 99, 9, 473, 99, 0, 10,
- 477, 478, 99, 99, 9, 99, 143, 9, 445, 11,
- 12, 457, 458, 86, 87, 99, 101, 472, 495, 92,
- 100, 71, 95, 96, 97, 98, 58, 59, 60, 61,
- 485, 101, 99, 99, 511, 9, 100, 39, 40, 41,
- 42, 70, 519, 101, 46, 491, 48, 99, 185, 51,
- 19, 99, 507, 85, 86, 87, 58, 59, 60, 61,
- 92, 99, 12, 95, 96, 97, 98, 204, 98, 305,
- 457, 73, 74, 75, 196, 77, 78, 79, 80, 81,
- 82, 83, 84, 85, 86, 87, 58, 59, 60, 61,
- 92, 512, 33, 95, 96, 97, 98, 99, 82, 101,
- 375, 58, 104, 60, 61, 0, 73, 74, 75, 244,
- 352, 83, 84, 85, 86, 87, 422, 12, 143, 318,
- 92, 204, 60, 95, 96, 97, 98, -1, -1, 86,
- 87, -1, 99, -1, -1, 92, -1, -1, 95, 96,
- 97, 98, -1, -1, 39, 40, 41, 42, 285, 87,
- -1, 46, -1, 48, 92, -1, 51, 95, 96, 97,
- 98, -1, -1, 58, 59, 60, 61, 73, 74, 75,
- -1, -1, 309, 73, 74, 75, -1, -1, 73, 74,
- 75, 318, 77, 78, 79, 80, 81, 82, 83, 84,
- 85, 86, 87, 99, -1, -1, -1, 92, -1, 99,
- 95, 96, 97, 98, 99, -1, 101, 0, 1, 104,
- -1, -1, -1, -1, -1, -1, 9, -1, 11, -1,
- 13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, 32,
- 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
- 60, 61, -1, 46, 47, 48, 49, 50, -1, 52,
- 53, 54, 55, 56, 57, 73, 74, 75, -1, 62,
- 63, 64, 65, 66, 67, 68, -1, 87, -1, -1,
- -1, -1, 92, 76, -1, 95, 96, 97, 98, -1,
- -1, 99, -1, -1, -1, 88, 89, -1, 91, -1,
- 93, 94, 0, 1, -1, -1, -1, 100, 101, 102,
- 103, 9, -1, 11, -1, 13, 14, 15, 16, 17,
- -1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
- 28, 29, 30, 31, 32, 33, 34, 35, 36, 37,
- 38, 39, 40, 41, 42, -1, -1, -1, 46, 47,
- 48, 49, 50, -1, 52, 53, 54, 55, 56, 57,
- -1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
- 68, 87, -1, -1, -1, -1, 92, -1, 76, 95,
- 96, 97, 98, 92, -1, -1, 95, 96, 97, 98,
- 88, 89, -1, 91, -1, 93, 94, -1, 1, -1,
- -1, -1, 100, 101, 102, 103, 9, 10, 11, -1,
- 13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, 32,
- 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
- -1, -1, -1, 46, 47, 48, 49, 50, -1, 52,
- 53, 54, 55, 56, 57, -1, -1, -1, -1, 62,
- 63, 64, 65, 66, 67, 68, 3, 4, 5, 6,
- 7, 8, -1, 76, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 88, 89, -1, 91, -1,
- 93, 94, -1, 1, -1, -1, -1, 100, 101, 102,
- 103, 9, 10, 11, -1, 13, 14, 15, 16, 17,
- -1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
- 28, 29, 30, 31, 32, 33, 34, 35, 36, 37,
- 38, 39, 40, 41, 42, -1, -1, -1, 46, 47,
- 48, 49, 50, -1, 52, 53, 54, 55, 56, 57,
- -1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
- 68, -1, -1, -1, -1, -1, -1, -1, 76, -1,
+ 15, 126, 317, 9, 40, 335, 426, 9, 11, 115,
+ 16, 46, 48, 46, 9, 23, 9, 77, 11, 11,
+ 10, 0, 461, 19, 20, 21, 23, 23, 24, 19,
+ 20, 21, 100, 23, 24, 141, 20, 43, 15, 16,
+ 17, 25, 17, 18, 40, 41, 15, 16, 54, 39,
+ 40, 41, 42, 9, 100, 30, 9, 9, 11, 34,
+ 56, 9, 122, 11, 39, 55, 56, 42, 20, 9,
+ 45, 100, 47, 25, 49, 50, 51, 52, 53, 115,
+ 20, 9, 100, 11, 9, 25, 11, 15, 16, 17,
+ 67, 421, 100, 21, 533, 98, 77, 133, 9, 101,
+ 225, 307, 92, 523, 101, 141, 101, 100, 143, 11,
+ 143, 317, 118, 77, 320, 321, 69, 100, 11, 125,
+ 126, 69, 9, 104, 454, 102, 20, 15, 16, 100,
+ 126, 121, 100, 102, 62, 9, 126, 11, 144, 199,
+ 200, 201, 202, 203, 69, 205, 206, 45, 208, 209,
+ 102, 103, 15, 16, 160, 161, 162, 100, 164, 165,
+ 166, 100, 102, 73, 74, 75, 100, 69, 143, 204,
+ 100, 204, 100, 100, 102, 103, 69, 43, 44, 194,
+ 186, 187, 188, 189, 190, 191, 192, 193, 163, 395,
+ 226, 101, 167, 168, 169, 170, 171, 172, 173, 174,
+ 175, 176, 177, 178, 179, 180, 181, 12, 214, 215,
+ 216, 217, 218, 219, 102, 530, 67, 101, 9, 225,
+ 11, 211, 100, 429, 430, 10, 99, 333, 91, 12,
+ 9, 237, 11, 73, 74, 75, 242, 100, 363, 102,
+ 91, 99, 12, 73, 74, 75, 252, 12, 9, 100,
+ 11, 102, 19, 20, 21, 69, 23, 24, 12, 319,
+ 466, 101, 12, 11, 20, 73, 74, 75, 73, 74,
+ 75, 277, 278, 40, 41, 9, 12, 11, 284, 46,
+ 20, 91, 12, 318, 100, 318, 99, 12, 55, 56,
+ 73, 74, 75, 101, 100, 285, 69, 333, 304, 305,
+ 306, 307, 508, 73, 74, 75, 10, 23, 73, 74,
+ 75, 317, 11, 373, 320, 321, 376, 377, 424, 73,
+ 74, 75, 89, 73, 74, 75, 75, 103, 388, 73,
+ 74, 75, 103, 428, 103, 103, 431, 73, 74, 75,
+ 435, 436, 348, 73, 74, 75, 103, 337, 73, 74,
+ 75, 39, 40, 41, 42, 99, 18, 363, 46, 126,
+ 48, 464, 457, 458, 39, 40, 41, 42, 73, 74,
+ 75, 46, 467, 48, 100, 20, 143, 352, 60, 61,
+ 483, 484, 73, 74, 75, 73, 74, 75, 424, 395,
+ 100, 486, 495, 399, 99, 490, 491, 100, 73, 74,
+ 75, 102, 99, 23, 86, 87, 509, 510, 99, 23,
+ 92, 99, 10, 95, 96, 97, 98, 512, 185, 10,
+ 51, 524, 10, 429, 430, 10, 10, 58, 59, 60,
+ 61, 20, 99, 448, 529, 99, 99, 204, 99, 99,
+ 455, 100, 537, 73, 74, 75, 101, 78, 79, 80,
+ 81, 82, 83, 84, 85, 86, 87, 99, 99, 465,
+ 466, 92, 99, 453, 95, 96, 97, 98, 9, 101,
+ 485, 101, 73, 74, 75, 10, 99, 58, 59, 60,
+ 61, 73, 74, 75, 100, 0, 9, 502, 99, 25,
+ 77, 73, 74, 75, 9, 99, 11, 12, 71, 101,
+ 101, 78, 508, 84, 85, 86, 87, 100, 9, 101,
+ 525, 92, 19, 99, 95, 96, 97, 98, 285, 101,
+ 99, 496, 70, 101, 39, 40, 41, 42, 73, 74,
+ 75, 46, 99, 48, 92, 99, 51, 95, 96, 97,
+ 98, 12, 309, 58, 59, 60, 61, 99, 73, 74,
+ 75, 318, 98, 465, 99, 33, 530, 196, 73, 74,
+ 75, 0, 77, 78, 79, 80, 81, 82, 83, 84,
+ 85, 86, 87, 12, 99, 375, 58, 92, 60, 61,
+ 95, 96, 97, 98, 99, 87, 101, 305, 82, 104,
+ 92, 60, 61, 95, 96, 97, 98, 244, 442, 422,
+ 39, 40, 41, 42, 86, 87, 473, 46, 472, 48,
+ 92, 143, 51, 95, 96, 97, 98, -1, 87, 58,
+ 59, 60, 61, 92, 318, -1, 95, 96, 97, 98,
+ 95, 96, 97, 98, 73, 74, 75, -1, 77, 78,
+ 79, 80, 81, 82, 83, 84, 85, 86, 87, 73,
+ 74, 75, -1, 92, 204, -1, 95, 96, 97, 98,
+ 99, -1, 101, 0, 1, 104, -1, -1, -1, -1,
+ -1, -1, 9, -1, 11, 99, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, 60, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
+ 57, 73, 74, 75, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, 87, 73, 74, 75, -1, 92, 76,
+ -1, 95, 96, 97, 98, -1, -1, 99, -1, -1,
+ -1, 88, 89, -1, 91, -1, 93, 94, 0, 1,
+ 99, -1, -1, 100, 101, 102, 103, 9, -1, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, 3, 4, 5,
+ 6, 7, 8, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, 1, -1, -1, -1, 100, 101,
+ 102, 103, 9, 10, 11, -1, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, -1, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
+ 57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 88, 89, -1, 91, -1, 93, 94, -1, 1, -1,
- -1, -1, 100, 101, 102, 103, 9, 10, 11, -1,
- 13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, 32,
- 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
- -1, -1, -1, 46, 47, 48, 49, 50, -1, 52,
- 53, 54, 55, 56, 57, -1, -1, -1, -1, 62,
- 63, 64, 65, 66, 67, 68, -1, -1, -1, -1,
- -1, -1, -1, 76, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 88, 89, -1, 91, -1,
- 93, 94, -1, 1, -1, -1, -1, 100, 101, 102,
- 103, 9, 10, 11, -1, 13, 14, 15, 16, 17,
- -1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
- 28, 29, 30, 31, 32, 33, 34, 35, 36, 37,
- 38, 39, 40, 41, 42, -1, -1, -1, 46, 47,
- 48, 49, 50, -1, 52, 53, 54, 55, 56, 57,
- -1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
- 68, -1, -1, -1, -1, -1, -1, -1, 76, -1,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, 1,
+ -1, -1, -1, 100, 101, 102, 103, 9, 10, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, -1, -1, -1,
+ -1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, 1, -1, -1, -1, 100, 101,
+ 102, 103, 9, 10, 11, -1, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, -1, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
+ 57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 88, 89, -1, 91, -1, 93, 94, -1, 1, -1,
- -1, -1, 100, 101, 102, 103, 9, 10, 11, -1,
- 13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, 32,
- 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
- -1, -1, -1, 46, 47, 48, 49, 50, -1, 52,
- 53, 54, 55, 56, 57, -1, -1, -1, -1, 62,
- 63, 64, 65, 66, 67, 68, -1, -1, -1, -1,
- -1, -1, -1, 76, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 88, 89, -1, 91, -1,
- 93, 94, -1, 1, -1, -1, -1, 100, 101, 102,
- 103, 9, -1, 11, -1, 13, 14, 15, 16, 17,
- -1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
- 28, 29, 30, 31, 32, 33, 34, 35, 36, 37,
- 38, 39, 40, 41, 42, -1, -1, -1, 46, 47,
- 48, 49, 50, -1, 52, 53, 54, 55, 56, 57,
- -1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
- 68, -1, -1, 71, -1, -1, -1, -1, 76, -1,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, 1,
+ -1, -1, -1, 100, 101, 102, 103, 9, 10, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, -1, -1, -1,
+ -1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, 1, -1, -1, -1, 100, 101,
+ 102, 103, 9, 10, 11, -1, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, -1, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
+ 57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 88, 89, -1, 91, -1, 93, 94, -1, 1, -1,
- -1, -1, 100, 101, 102, 103, 9, -1, 11, -1,
- 13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, 32,
- 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
- -1, -1, -1, 46, 47, 48, 49, 50, -1, 52,
- 53, 54, 55, 56, 57, -1, -1, -1, -1, 62,
- 63, 64, 65, 66, 67, 68, -1, -1, -1, -1,
- -1, -1, -1, 76, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 88, 89, -1, 91, -1,
- 93, 94, -1, 1, -1, -1, -1, 100, 101, 102,
- 103, 9, -1, 11, -1, 13, 14, 15, 16, 17,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, 1,
+ -1, -1, -1, 100, 101, 102, 103, 9, -1, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, -1, -1, 71,
+ -1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, 1, -1, -1, -1, 100, 101,
+ 102, 103, 9, -1, 11, -1, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, -1, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
+ 57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, 1,
+ -1, -1, -1, 100, 101, 102, 103, 9, -1, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, -1, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, -1, -1, -1,
+ -1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, 1, -1, -1, -1, -1, 100, 101,
+ 102, 103, -1, 11, -1, 13, 14, 15, 16, 17,
-1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
- 28, 29, 30, 31, 32, -1, 34, 35, 36, 37,
- 38, 39, 40, 41, 42, -1, -1, -1, 46, 47,
- 48, 49, 50, -1, 52, 53, 54, 55, 56, 57,
+ 28, 29, 30, 31, -1, -1, -1, -1, 36, -1,
+ -1, 51, -1, -1, -1, -1, -1, -1, 58, 59,
+ 60, 61, 50, -1, 52, 53, 54, 55, 56, 57,
-1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
- 68, -1, -1, -1, -1, -1, -1, -1, 76, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 68, 81, 82, 83, 84, 85, 86, 87, 76, -1,
+ -1, -1, 92, -1, -1, 95, 96, 97, 98, -1,
88, 89, -1, 91, -1, 93, 94, 1, -1, -1,
-1, -1, 100, 101, 102, 103, -1, 11, -1, 13,
14, 15, 16, 17, -1, -1, 20, 21, 22, 23,
24, -1, 26, 27, 28, 29, 30, 31, -1, -1,
- -1, -1, 36, -1, -1, 51, -1, -1, -1, -1,
- -1, -1, 58, 59, 60, 61, 50, -1, 52, 53,
+ -1, -1, 36, -1, -1, -1, -1, -1, -1, -1,
+ 58, 59, 60, 61, -1, -1, 50, -1, 52, 53,
54, 55, 56, 57, -1, -1, -1, -1, 62, 63,
- 64, 65, 66, 67, 68, 81, 82, 83, 84, 85,
- 86, 87, 76, -1, -1, -1, 92, -1, -1, 95,
- 96, 97, 98, -1, 88, 89, -1, 91, -1, 93,
- 94, 1, -1, -1, -1, -1, 100, 101, 102, 103,
- -1, 11, -1, 13, 14, 15, 16, 17, -1, -1,
- 20, 21, 22, 23, 24, -1, 26, 27, 28, 29,
- 30, 31, -1, -1, -1, -1, 36, -1, -1, -1,
- -1, -1, -1, 58, 59, 60, 61, -1, -1, -1,
- 50, -1, 52, 53, 54, 55, 56, 57, -1, -1,
- -1, -1, 62, 63, 64, 65, 66, 67, 68, 84,
- 85, 86, 87, -1, -1, -1, 76, 92, -1, -1,
- 95, 96, 97, 98, -1, -1, -1, -1, 88, 89,
- -1, 91, -1, 93, 94, -1, -1, -1, -1, 99,
- 100, -1, 102, 103, 9, -1, 11, -1, 13, 14,
- 15, 16, 17, -1, -1, 20, 21, 22, 23, 24,
- 25, 26, 27, 28, 29, 30, 31, -1, -1, -1,
- -1, 36, -1, -1, -1, -1, 58, 59, 60, 61,
- -1, -1, -1, -1, -1, 50, -1, 52, 53, 54,
- 55, 56, 57, -1, -1, -1, -1, 62, 63, 64,
- 65, 66, 67, 68, 86, 87, -1, -1, -1, -1,
- 92, 76, -1, 95, 96, 97, 98, -1, -1, -1,
- -1, -1, -1, 88, 89, -1, 91, -1, 93, 94,
- -1, -1, -1, -1, -1, 100, -1, 102, 103, 9,
- -1, 11, -1, 13, 14, 15, 16, 17, -1, -1,
- 20, 21, 22, 23, 24, -1, 26, 27, 28, 29,
- 30, 31, -1, -1, -1, -1, 36, -1, -1, -1,
- -1, 58, 59, 60, 61, -1, -1, -1, -1, -1,
- 50, -1, 52, 53, 54, 55, 56, 57, -1, -1,
- -1, -1, 62, 63, 64, 65, 66, 67, 68, 86,
- 87, -1, -1, -1, -1, 92, 76, -1, 95, 96,
- 97, 98, -1, -1, -1, -1, -1, -1, 88, 89,
- -1, 91, -1, 93, 94, -1, -1, -1, -1, -1,
- 100, -1, 102, 103, 11, 12, 13, 14, 15, 16,
- 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
- 27, 28, 29, 30, 31, -1, -1, -1, -1, 36,
- 39, 40, 41, 42, -1, -1, -1, 46, -1, 48,
- -1, -1, -1, 50, -1, 52, 53, 54, 55, 56,
- 57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
- 67, 68, -1, -1, 73, 74, 75, -1, -1, 76,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 88, 89, -1, 91, -1, 93, 94, -1, -1,
- -1, -1, -1, 100, -1, 102, 103, 11, -1, 13,
+ 64, 65, 66, 67, 68, 83, 84, 85, 86, 87,
+ -1, -1, 76, -1, 92, -1, -1, 95, 96, 97,
+ 98, -1, -1, -1, 88, 89, -1, 91, -1, 93,
+ 94, -1, -1, -1, -1, 99, 100, -1, 102, 103,
+ 9, -1, 11, -1, 13, 14, 15, 16, 17, -1,
+ -1, 20, 21, 22, 23, 24, 25, 26, 27, 28,
+ 29, 30, 31, -1, -1, -1, -1, 36, -1, -1,
+ -1, -1, -1, -1, 58, 59, 60, 61, -1, -1,
+ -1, 50, -1, 52, 53, 54, 55, 56, 57, -1,
+ -1, -1, -1, 62, 63, 64, 65, 66, 67, 68,
+ -1, 85, 86, 87, -1, -1, -1, 76, 92, -1,
+ -1, 95, 96, 97, 98, -1, -1, -1, -1, 88,
+ 89, -1, 91, -1, 93, 94, -1, -1, -1, -1,
+ -1, 100, -1, 102, 103, 9, -1, 11, -1, 13,
14, 15, 16, 17, -1, -1, 20, 21, 22, 23,
24, -1, 26, 27, 28, 29, 30, 31, -1, -1,
- -1, -1, 36, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 50, -1, 52, 53,
+ -1, -1, 36, -1, -1, -1, -1, 58, 59, 60,
+ 61, -1, -1, -1, -1, -1, 50, -1, 52, 53,
54, 55, 56, 57, -1, -1, -1, -1, 62, 63,
- 64, 65, 66, 67, 68, -1, -1, -1, -1, -1,
- -1, -1, 76, -1, -1, -1, -1, -1, -1, -1,
+ 64, 65, 66, 67, 68, 86, 87, -1, -1, -1,
+ -1, 92, 76, -1, 95, 96, 97, 98, -1, -1,
-1, -1, -1, -1, 88, 89, -1, 91, -1, 93,
- 94, -1, -1, -1, -1, -1, 100, 101, 102, 103,
- 11, -1, 13, 14, 15, 16, 17, -1, -1, 20,
+ 94, -1, -1, -1, -1, -1, 100, -1, 102, 103,
+ 11, 12, 13, 14, 15, 16, 17, -1, -1, 20,
21, 22, 23, 24, -1, 26, 27, 28, 29, 30,
31, -1, -1, -1, -1, 36, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 50,
+ 58, 59, 60, 61, -1, -1, -1, -1, -1, 50,
-1, 52, 53, 54, 55, 56, 57, -1, -1, -1,
- -1, 62, 63, 64, 65, 66, 67, 68, -1, -1,
- -1, -1, -1, -1, -1, 76, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 88, 89, -1,
- 91, -1, 93, 94, -1, -1, -1, -1, 99, 100,
+ -1, 62, 63, 64, 65, 66, 67, 68, 86, 87,
+ -1, -1, -1, -1, 92, 76, -1, 95, 96, 97,
+ 98, -1, -1, -1, -1, -1, -1, 88, 89, -1,
+ 91, -1, 93, 94, -1, -1, -1, -1, -1, 100,
-1, 102, 103, 11, -1, 13, 14, 15, 16, 17,
-1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
28, 29, 30, 31, -1, -1, -1, -1, 36, -1,
68, -1, -1, -1, -1, -1, -1, -1, 76, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
88, 89, -1, 91, -1, 93, 94, -1, -1, -1,
- -1, 99, 100, -1, 102, 103, 11, -1, 13, 14,
+ -1, -1, 100, 101, 102, 103, 11, -1, 13, 14,
15, 16, 17, -1, -1, 20, 21, 22, 23, 24,
-1, 26, 27, 28, 29, 30, 31, -1, -1, -1,
-1, 36, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, 62, 63, 64, 65, 66, 67, 68, -1,
-1, -1, -1, -1, -1, -1, 76, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, 88, 89,
- -1, 91, -1, 93, 94, -1, -1, -1, -1, -1,
+ -1, 91, -1, 93, 94, -1, -1, -1, -1, 99,
100, -1, 102, 103, 11, -1, 13, 14, 15, 16,
17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
27, 28, 29, 30, 31, -1, -1, -1, -1, 36,
-1, -1, -1, 50, -1, 52, 53, 54, 55, 56,
57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
- 51, -1, -1, -1, -1, -1, -1, 58, 59, 60,
- 61, 88, 89, -1, 91, -1, 93, 94, -1, -1,
- -1, -1, -1, 100, -1, 102, 103, 78, 79, 80,
- 81, 82, 83, 84, 85, 86, 87, -1, -1, -1,
- -1, 92, 51, -1, 95, 96, 97, 98, -1, 58,
- 59, 60, 61, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 78,
- 79, -1, 81, 82, 83, 84, 85, 86, 87, -1,
- -1, -1, -1, 92, 51, -1, 95, 96, 97, 98,
- -1, 58, 59, 60, 61, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 79, -1, 81, 82, 83, 84, 85, 86,
- 87, -1, -1, -1, -1, 92, -1, -1, 95, 96,
- 97, 98
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, -1,
+ -1, -1, 99, 100, -1, 102, 103, 11, -1, 13,
+ 14, 15, 16, 17, -1, -1, 20, 21, 22, 23,
+ 24, -1, 26, 27, 28, 29, 30, 31, -1, -1,
+ -1, -1, 36, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 50, -1, 52, 53,
+ 54, 55, 56, 57, -1, -1, -1, -1, 62, 63,
+ 64, 65, 66, 67, 68, -1, -1, -1, -1, -1,
+ -1, -1, 76, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 88, 89, -1, 91, -1, 93,
+ 94, -1, -1, -1, -1, -1, 100, -1, 102, 103,
+ 11, -1, 13, 14, 15, 16, 17, -1, -1, 20,
+ 21, 22, 23, 24, -1, 26, 27, 28, 29, 30,
+ 31, -1, -1, -1, -1, 36, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 50,
+ -1, 52, 53, 54, 55, 56, 57, -1, -1, -1,
+ -1, 62, 63, 64, 65, 66, 67, 68, -1, -1,
+ -1, -1, -1, -1, -1, 76, 51, -1, -1, -1,
+ -1, -1, -1, 58, 59, 60, 61, 88, 89, -1,
+ 91, -1, 93, 94, -1, -1, -1, -1, -1, 100,
+ -1, 102, 103, 78, 79, -1, 81, 82, 83, 84,
+ 85, 86, 87, -1, -1, -1, -1, 92, 51, -1,
+ 95, 96, 97, 98, -1, 58, 59, 60, 61, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 79, -1, 81, 82,
+ 83, 84, 85, 86, 87, -1, -1, -1, -1, 92,
+ -1, -1, 95, 96, 97, 98
};
/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
16, 17, 20, 21, 22, 23, 24, 26, 27, 28,
29, 30, 31, 36, 50, 52, 53, 54, 55, 56,
57, 62, 63, 64, 65, 66, 67, 68, 76, 88,
- 89, 91, 93, 94, 100, 102, 103, 152, 153, 154,
- 157, 158, 159, 160, 161, 162, 164, 167, 173, 174,
- 175, 176, 177, 178, 179, 180, 181, 9, 113, 1,
+ 89, 91, 93, 94, 100, 102, 103, 160, 161, 162,
+ 165, 166, 167, 168, 169, 170, 172, 175, 181, 182,
+ 183, 184, 185, 186, 187, 188, 189, 9, 113, 1,
32, 34, 35, 37, 38, 39, 40, 41, 42, 46,
- 47, 48, 49, 101, 113, 122, 132, 152, 33, 120,
- 121, 122, 118, 118, 12, 152, 162, 162, 20, 25,
- 113, 174, 182, 182, 182, 182, 182, 163, 11, 100,
- 162, 143, 143, 162, 100, 100, 100, 113, 162, 20,
- 153, 166, 174, 182, 182, 113, 162, 101, 152, 20,
- 25, 145, 162, 91, 100, 165, 174, 175, 176, 162,
- 153, 162, 162, 162, 162, 162, 99, 152, 182, 182,
+ 47, 48, 49, 101, 113, 122, 132, 160, 33, 120,
+ 121, 122, 118, 118, 12, 160, 170, 170, 20, 25,
+ 113, 182, 190, 190, 190, 190, 190, 171, 11, 100,
+ 170, 143, 143, 170, 100, 100, 100, 113, 170, 20,
+ 161, 174, 182, 190, 190, 113, 170, 101, 160, 20,
+ 25, 145, 170, 91, 100, 173, 182, 183, 184, 170,
+ 161, 170, 170, 170, 170, 170, 99, 160, 190, 190,
73, 74, 75, 77, 9, 11, 100, 51, 58, 59,
60, 61, 78, 79, 81, 82, 83, 84, 85, 86,
87, 92, 95, 96, 97, 98, 100, 9, 11, 9,
11, 9, 11, 9, 115, 144, 145, 20, 142, 100,
- 100, 100, 100, 67, 91, 100, 172, 174, 100, 100,
+ 100, 100, 100, 67, 91, 100, 180, 182, 100, 100,
113, 45, 134, 101, 39, 40, 41, 42, 46, 48,
- 121, 122, 120, 12, 166, 100, 100, 152, 99, 113,
- 23, 115, 146, 99, 99, 152, 167, 182, 153, 10,
- 101, 166, 100, 162, 165, 174, 175, 176, 99, 152,
- 69, 148, 11, 99, 152, 152, 152, 162, 152, 152,
- 99, 152, 162, 162, 162, 162, 162, 162, 162, 162,
- 162, 162, 162, 162, 162, 162, 162, 9, 11, 15,
- 16, 17, 21, 62, 100, 102, 103, 156, 174, 99,
- 152, 152, 152, 152, 152, 152, 152, 152, 118, 20,
+ 121, 122, 120, 12, 174, 100, 100, 160, 99, 113,
+ 23, 115, 146, 99, 99, 160, 175, 190, 161, 10,
+ 101, 174, 100, 170, 173, 182, 183, 184, 99, 160,
+ 69, 148, 11, 99, 160, 160, 160, 170, 160, 160,
+ 99, 160, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 9, 11, 15,
+ 16, 17, 21, 62, 100, 102, 103, 164, 182, 99,
+ 160, 160, 160, 160, 160, 160, 160, 160, 118, 20,
141, 142, 20, 125, 115, 115, 115, 115, 91, 115,
- 67, 170, 171, 173, 174, 175, 176, 115, 115, 100,
- 115, 115, 113, 152, 138, 152, 152, 152, 152, 152,
- 167, 153, 12, 155, 100, 149, 69, 147, 99, 99,
- 152, 10, 99, 152, 148, 99, 23, 152, 11, 101,
- 12, 99, 80, 152, 152, 103, 103, 103, 103, 99,
- 152, 103, 103, 100, 99, 101, 12, 101, 12, 101,
+ 67, 178, 179, 181, 182, 183, 184, 115, 115, 100,
+ 115, 115, 113, 160, 138, 160, 160, 160, 160, 160,
+ 175, 161, 12, 163, 100, 157, 69, 147, 99, 99,
+ 160, 10, 99, 160, 148, 99, 23, 160, 11, 101,
+ 12, 99, 80, 160, 160, 103, 103, 103, 103, 99,
+ 160, 103, 103, 100, 99, 101, 12, 101, 12, 101,
12, 101, 10, 18, 114, 123, 124, 9, 101, 20,
- 137, 152, 138, 139, 152, 139, 169, 174, 100, 132,
- 136, 139, 140, 152, 170, 115, 139, 139, 99, 104,
- 168, 166, 150, 147, 23, 113, 99, 99, 12, 152,
- 10, 162, 101, 12, 99, 167, 10, 10, 10, 10,
+ 137, 160, 138, 139, 160, 139, 177, 182, 100, 132,
+ 136, 139, 140, 160, 178, 115, 139, 139, 99, 104,
+ 176, 174, 158, 147, 23, 113, 99, 99, 12, 160,
+ 10, 170, 101, 12, 99, 175, 10, 10, 10, 10,
115, 146, 115, 115, 20, 99, 99, 99, 99, 100,
- 115, 99, 101, 128, 139, 99, 99, 152, 99, 99,
- 9, 12, 10, 99, 101, 147, 149, 129, 166, 135,
- 135, 9, 116, 116, 139, 139, 116, 126, 100, 99,
- 116, 116, 118, 71, 101, 113, 151, 147, 118, 101,
- 116, 116, 117, 43, 44, 133, 133, 99, 99, 134,
- 137, 139, 116, 10, 119, 9, 10, 134, 134, 118,
- 116, 100, 116, 116, 101, 99, 134, 23, 101, 130,
- 118, 10, 139, 134, 134, 127, 116, 70, 131, 19,
- 10, 99, 135, 134, 118, 116, 140, 71, 133, 99,
- 116
+ 115, 99, 101, 128, 139, 99, 99, 160, 99, 15,
+ 16, 102, 150, 151, 153, 154, 155, 156, 9, 12,
+ 10, 99, 101, 147, 157, 129, 174, 135, 135, 9,
+ 116, 116, 139, 139, 116, 126, 100, 99, 116, 116,
+ 25, 149, 149, 77, 99, 118, 71, 101, 113, 159,
+ 147, 118, 101, 116, 116, 117, 43, 44, 133, 133,
+ 99, 99, 134, 137, 139, 116, 78, 152, 152, 154,
+ 10, 119, 9, 10, 134, 134, 118, 116, 100, 116,
+ 116, 101, 99, 134, 170, 23, 101, 130, 118, 10,
+ 139, 134, 134, 127, 116, 70, 131, 19, 10, 99,
+ 135, 134, 118, 116, 140, 71, 133, 99, 116
};
/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
132, 132, 132, 132, 132, 132, 132, 132, 133, 133,
133, 134, 134, 135, 136, 136, 137, 137, 138, 139,
140, 141, 141, 142, 143, 144, 145, 145, 146, 146,
- 147, 147, 147, 148, 148, 150, 149, 151, 151, 152,
- 152, 152, 152, 153, 153, 153, 154, 154, 154, 154,
- 154, 154, 154, 154, 155, 154, 156, 156, 157, 157,
- 157, 157, 157, 157, 157, 157, 157, 157, 157, 157,
- 157, 157, 158, 158, 158, 158, 158, 158, 158, 158,
- 158, 158, 158, 158, 158, 158, 159, 159, 159, 159,
- 159, 159, 159, 159, 159, 160, 160, 160, 160, 160,
- 160, 161, 161, 162, 162, 162, 162, 162, 162, 162,
- 162, 162, 162, 162, 162, 162, 162, 162, 162, 162,
- 162, 162, 162, 162, 162, 162, 162, 162, 162, 162,
- 162, 162, 162, 162, 162, 162, 162, 162, 162, 162,
- 162, 162, 162, 162, 162, 162, 162, 162, 162, 162,
- 162, 162, 163, 162, 162, 162, 162, 162, 164, 164,
- 164, 165, 165, 165, 165, 165, 166, 166, 167, 167,
- 168, 168, 169, 170, 170, 170, 171, 171, 172, 172,
- 173, 174, 175, 176, 177, 177, 178, 179, 179, 180,
- 180, 181, 181, 182, 182, 182, 182
+ 147, 147, 147, 148, 148, 149, 149, 150, 150, 151,
+ 152, 152, 152, 153, 154, 154, 155, 155, 155, 156,
+ 156, 158, 157, 159, 159, 160, 160, 160, 160, 161,
+ 161, 161, 162, 162, 162, 162, 162, 162, 162, 162,
+ 163, 162, 164, 164, 165, 165, 165, 165, 165, 165,
+ 165, 165, 165, 165, 165, 165, 165, 165, 166, 166,
+ 166, 166, 166, 166, 166, 166, 166, 166, 166, 166,
+ 166, 166, 167, 167, 167, 167, 167, 167, 167, 167,
+ 167, 168, 168, 168, 168, 168, 168, 169, 169, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 171, 170,
+ 170, 170, 170, 170, 172, 172, 172, 173, 173, 173,
+ 173, 173, 174, 174, 175, 175, 176, 176, 177, 178,
+ 178, 178, 179, 179, 180, 180, 181, 182, 183, 184,
+ 185, 185, 186, 187, 187, 188, 188, 189, 189, 190,
+ 190, 190, 190
};
/* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */
1, 1, 3, 3, 3, 3, 3, 3, 0, 2,
6, 0, 2, 0, 0, 1, 0, 1, 1, 1,
1, 1, 0, 0, 0, 0, 1, 1, 0, 1,
- 0, 2, 1, 2, 1, 0, 3, 1, 1, 3,
- 3, 3, 1, 2, 3, 1, 3, 5, 6, 3,
- 3, 5, 2, 4, 0, 5, 1, 1, 5, 4,
- 5, 4, 5, 6, 5, 4, 5, 4, 3, 6,
- 4, 5, 3, 3, 3, 3, 3, 3, 3, 3,
- 3, 3, 3, 3, 3, 3, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 3, 2, 4, 3, 5,
- 8, 2, 2, 1, 1, 1, 1, 5, 2, 3,
- 1, 2, 3, 1, 2, 1, 1, 1, 1, 1,
- 1, 4, 4, 5, 5, 1, 1, 3, 4, 3,
- 4, 4, 4, 4, 4, 1, 2, 2, 1, 2,
- 2, 1, 2, 1, 2, 1, 3, 1, 3, 1,
- 3, 4, 0, 6, 1, 1, 1, 1, 3, 2,
- 4, 3, 2, 1, 1, 1, 0, 1, 0, 1,
- 0, 2, 1, 1, 1, 1, 1, 1, 2, 2,
- 2, 2, 2, 2, 2, 4, 2, 1, 3, 1,
- 3, 1, 3, 1, 1, 1, 1
+ 0, 2, 1, 2, 1, 0, 1, 1, 1, 3,
+ 0, 1, 2, 3, 1, 1, 2, 3, 1, 0,
+ 1, 0, 4, 1, 1, 3, 3, 3, 1, 2,
+ 3, 1, 3, 5, 6, 3, 3, 5, 2, 4,
+ 0, 5, 1, 1, 5, 4, 5, 4, 5, 6,
+ 5, 4, 5, 4, 3, 6, 4, 5, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 3, 2, 4, 3, 5, 8, 2, 2, 1,
+ 1, 1, 1, 5, 2, 3, 1, 2, 3, 1,
+ 2, 1, 1, 1, 1, 1, 1, 4, 4, 5,
+ 5, 1, 1, 3, 4, 3, 4, 4, 4, 4,
+ 4, 1, 2, 2, 1, 2, 2, 1, 2, 1,
+ 2, 1, 3, 1, 3, 1, 3, 4, 0, 6,
+ 1, 1, 1, 1, 3, 2, 4, 3, 2, 1,
+ 1, 1, 0, 1, 0, 1, 0, 2, 1, 1,
+ 1, 1, 1, 1, 2, 2, 2, 2, 2, 2,
+ 2, 4, 2, 1, 3, 1, 3, 1, 3, 1,
+ 1, 1, 1
};
typedef enum {
toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_ival, toketype_opval,
toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval
+ toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval
};
/* Generated from:
- * fba24dfc68a3a84c9ae95cb9e14cc156ac487e6f3228cdf84c166d3cd820e59a perly.y
+ * 1a8fc0f841dee6e563463a6b91bf9c410b47437c760f485a16d87ade3d66bf1d perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
%type <opval> formname subname proto optsubbody cont my_scalar my_var
%type <opval> refgen_topic formblock
%type <opval> subattrlist myattrlist myattrterm myterm
-%type <opval> subsignature termbinop termunop anonymous termdo
+%type <opval> termbinop termunop anonymous termdo
+%type <ival> sigslurpsigil
+%type <opval> sigvarname sigdefault sigscalarelem sigslurpelem
+%type <opval> sigelem siglist siglistornull subsignature
%type <opval> formstmtseq formline formarg
%nonassoc <ival> PREC_LOW
{ $$ = (OP*)NULL; }
;
-/* Subroutine signature */
-subsignature: '('
- {
- /* We shouldn't get here otherwise */
- assert(FEATURE_SIGNATURES_IS_ENABLED);
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__SIGNATURES),
- "The signatures feature is experimental");
- $<opval>$ = parse_subsignature();
+
+/* --------------------------------------
+ * subroutine signature parsing
+ */
+
+/* the '' or 'foo' part of a '$' or '@foo' etc signature variable */
+sigvarname: /* NULL */
+ { parser->in_my = 0; $$ = (OP*)NULL; }
+ | PRIVATEREF
+ { parser->in_my = 0; $$ = $1; }
+ ;
+
+sigslurpsigil:
+ '@'
+ { $$ = '@'; }
+ | '%'
+ { $$ = '%'; }
+
+/* @, %, @foo, %foo */
+sigslurpelem: sigslurpsigil sigvarname sigdefault/* def only to catch errors */
+ {
+ I32 sigil = $1;
+ OP *var = $2;
+ OP *defexpr = $3;
+
+ if (parser->sig_slurpy)
+ yyerror("Multiple slurpy parameters not allowed");
+ parser->sig_slurpy = (char)sigil;
+
+ if (defexpr)
+ yyerror("A slurpy parameter may not have "
+ "a default value");
+
+ $$ = var ? newSTATEOP(0, NULL, var) : (OP*)NULL;
+ }
+ ;
+
+/* default part of sub signature scalar element: i.e. '= default_expr' */
+sigdefault: /* NULL */
+ { $$ = (OP*)NULL; }
+ | ASSIGNOP
+ { $$ = newOP(OP_NULL, 0); }
+ | ASSIGNOP term
+ { $$ = $2; }
+
+
+/* subroutine signature scalar element: e.g. '$x', '$=', '$x = $default' */
+sigscalarelem:
+ '$' sigvarname sigdefault
+ {
+ OP *var = $2;
+ OP *defexpr = $3;
+
+ if (parser->sig_slurpy)
+ yyerror("Slurpy parameter not last");
+
+ parser->sig_elems++;
+
+ if (defexpr) {
+ parser->sig_optelems++;
+
+ if ( defexpr->op_type == OP_NULL
+ && !(defexpr->op_flags & OPf_KIDS))
+ {
+ /* handle '$=' special case */
+ if (var)
+ yyerror("Optional parameter "
+ "lacks default expression");
+ op_free(defexpr);
+ }
+ else {
+ /* a normal '=default' expression */
+ OP *defop = (OP*)alloc_LOGOP(OP_ARGDEFELEM,
+ defexpr,
+ LINKLIST(defexpr));
+ /* re-purpose op_targ to hold @_ index */
+ defop->op_targ =
+ (PADOFFSET)(parser->sig_elems - 1);
+
+ if (var) {
+ var->op_flags |= OPf_STACKED;
+ (void)op_sibling_splice(var,
+ NULL, 0, defop);
+ scalar(defop);
+ }
+ else
+ var = newUNOP(OP_NULL, 0, defop);
+
+ LINKLIST(var);
+ /* NB: normally the first child of a
+ * logop is executed before the logop,
+ * and it pushes a boolean result
+ * ready for the logop. For ARGDEFELEM,
+ * the op itself does the boolean
+ * calculation, so set the first op to
+ * it instead.
+ */
+ var->op_next = defop;
+ defexpr->op_next = var;
+ }
+ }
+ else {
+ if (parser->sig_optelems)
+ yyerror("Mandatory parameter "
+ "follows optional parameter");
+ }
+
+ $$ = var ? newSTATEOP(0, NULL, var) : (OP*)NULL;
+ }
+ ;
+
+
+/* subroutine signature element: e.g. '$x = $default' or '%h' */
+sigelem: sigscalarelem
+ { parser->in_my = KEY_sigvar; $$ = $1; }
+ | sigslurpelem
+ { parser->in_my = KEY_sigvar; $$ = $1; }
+ ;
+
+/* list of subroutine signature elements */
+siglist:
+ siglist ','
+ { $$ = $1; }
+ | siglist ',' sigelem
+ {
+ $$ = op_append_list(OP_LINESEQ, $1, $3);
}
- ')'
+ | sigelem %prec PREC_LOW
+ { $$ = $1; }
+ ;
+
+/* () or (....) */
+siglistornull: /* NULL */
+ { $$ = (OP*)NULL; }
+ | siglist
+ { $$ = $1; }
+
+/* Subroutine signature */
+subsignature: '('
+ {
+ ENTER;
+ SAVEIV(parser->sig_elems);
+ SAVEIV(parser->sig_optelems);
+ SAVEI8(parser->sig_slurpy);
+ parser->sig_elems = 0;
+ parser->sig_optelems = 0;
+ parser->sig_slurpy = 0;
+ parser->in_my = KEY_sigvar;
+ }
+ siglistornull
+ ')'
{
- $$ = op_append_list(OP_LINESEQ, $<opval>2,
- newSTATEOP(0, NULL, sawparens(newNULLLIST())));
- parser->expect = XATTRBLOCK;
+ OP *sigops = $3;
+ UNOP_AUX_item *aux;
+ OP *check;
+
+ assert(FEATURE_SIGNATURES_IS_ENABLED);
+
+ /* We shouldn't get here otherwise */
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SIGNATURES),
+ "The signatures feature is experimental");
+
+ aux = (UNOP_AUX_item*)PerlMemShared_malloc(
+ sizeof(UNOP_AUX_item) * 3);
+ aux[0].iv = parser->sig_elems;
+ aux[1].iv = parser->sig_optelems;
+ aux[2].iv = parser->sig_slurpy;
+ check = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux);
+ sigops = op_prepend_elem(OP_LINESEQ, check, sigops);
+ sigops = op_prepend_elem(OP_LINESEQ,
+ newSTATEOP(0, NULL, NULL),
+ sigops);
+ /* a nextstate at the end handles context
+ * correctly for an empty sub body */
+ $$ = op_append_elem(OP_LINESEQ,
+ sigops,
+ newSTATEOP(0, NULL, NULL));
+
+ parser->in_my = 0;
+ parser->expect = XATTRBLOCK;
+ LEAVE;
}
;
+
+
/* Optional subroutine body, for named subroutine declaration */
optsubbody: block
| ';' { $$ = (OP*)NULL; }
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define PRIVLIB "/sys/lib/perl/5.25.3" /**/
-#define PRIVLIB_EXP "/sys/lib/perl/5.25.3" /**/
+#define PRIVLIB "/sys/lib/perl/5.25.4" /**/
+#define PRIVLIB_EXP "/sys/lib/perl/5.25.4" /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
-#define SITELIB "/sys/lib/perl/5.25.3/site_perl" /**/
-#define SITELIB_EXP "/sys/lib/perl/5.25.3/site_perl" /**/
-#define SITELIB_STEM "/sys/lib/perl/5.25.3/site_perl" /**/
+#define SITELIB "/sys/lib/perl/5.25.4/site_perl" /**/
+#define SITELIB_EXP "/sys/lib/perl/5.25.4/site_perl" /**/
+#define SITELIB_STEM "/sys/lib/perl/5.25.4/site_perl" /**/
/* Size_t_size:
* This symbol holds the size of a Size_t in bytes.
ansi2knr=''
aphostname='/bin/uname -n'
api_revision='5'
-api_subversion='3'
+api_subversion='4'
api_version='25'
-api_versionstring='5.25.3'
+api_versionstring='5.25.4'
ar='ar'
-archlib='/sys/lib/perl5/5.25.3/386'
-archlibexp='/sys/lib/perl5/5.25.3/386'
+archlib='/sys/lib/perl5/5.25.4/386'
+archlibexp='/sys/lib/perl5/5.25.4/386'
archname64=''
archname='386'
archobjs=''
d_ftello='undef'
d_ftime='undef'
d_futimes='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='stdarg.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs=''
inc_version_list=' '
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='/sys/lib/perl/5.25.3/386'
+installarchlib='/sys/lib/perl/5.25.4/386'
installbin='/usr/bin'
installman1dir='/sys/man/1pub'
installman3dir='/sys/man/2pub'
installprefix='/usr'
installprefixexp='/usr'
-installprivlib='/sys/lib/perl/5.25.3'
+installprivlib='/sys/lib/perl/5.25.4'
installscript='/usr/bin'
-installsitearch='/sys/lib/perl/5.25.3/site_perl/386'
+installsitearch='/sys/lib/perl/5.25.4/site_perl/386'
installsitebin='/usr/bin'
-installsitelib='/sys/lib/perl/5.25.3/site_perl'
+installsitelib='/sys/lib/perl/5.25.4/site_perl'
installstyle='lib/perl5'
installusrbinperl='undef'
installvendorarch=''
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/sys/lib/perl/5.25.3'
-privlibexp='/sys/lib/perl/5.25.3'
+privlib='/sys/lib/perl/5.25.4'
+privlibexp='/sys/lib/perl/5.25.4'
procselfexe=''
prototype='define'
ptrsize='4'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0'
sig_size='50'
signal_t='void'
-sitearch='/sys/lib/perl/5.25.3/site_perl/386'
+sitearch='/sys/lib/perl/5.25.4/site_perl/386'
sitearchexp='/sys/lib/perl/site_perl/386'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
-sitelib='/sys/lib/perl/5.25.3/site_perl'
-sitelib_stem='/sys/lib/perl/5.25.3/site_perl'
-sitelibexp='/sys/lib/perl/5.25.3/site_perl'
+sitelib='/sys/lib/perl/5.25.4/site_perl'
+sitelib_stem='/sys/lib/perl/5.25.4/site_perl'
+sitelibexp='/sys/lib/perl/5.25.4/site_perl'
siteprefix='/usr'
siteprefixexp='/usr'
sizesize='4'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='3'
+subversion='4'
sysman='/sys/man/1pub'
tail=''
tar=''
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='5.25.3'
-version_patchlevel_string='version 25 subversion 3'
+version='5.25.4'
+version_patchlevel_string='version 25 subversion 4'
versiononly='undef'
vi=''
xlibpth=''
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=3
+PERL_SUBVERSION=4
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=3
+PERL_API_SUBVERSION=4
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
/roffitall
# generated
-/perl5253delta.pod
+/perl5254delta.pod
/perlapi.pod
/perlintern.pod
*.html
perlhist Perl history records
perldelta Perl changes since previous version
+ perl5253delta Perl changes in version 5.25.3
perl5252delta Perl changes in version 5.25.2
perl5251delta Perl changes in version 5.25.1
perl5250delta Perl changes in version 5.25.0
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+perl5253delta - what is new for perl v5.25.3
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.25.2 release and the 5.25.3
+release.
+
+If you are upgrading from an earlier release such as 5.25.1, first read
+L<perl5252delta>, which describes differences between 5.25.1 and 5.25.2.
+
+=head1 Core Enhancements
+
+=head2 Unicode 9.0 is now supported
+
+A list of changes is at L<http://www.unicode.org/versions/Unicode9.0.0/>.
+Modules that are shipped with core Perl but not maintained by p5p do not
+necessarily support Unicode 9.0. L<Unicode::Normalize> does work on 9.0.
+
+=head2 Use of C<\p{I<script>}> uses the improved Script_Extensions property
+
+Unicode 6.0 introduced an improved form of the Script (C<sc>) property, and
+called it Script_Extensions (C<scx>). As of now, Perl uses this improved
+version when a property is specified as just C<\p{I<script>}>. The meaning of
+compound forms, like C<\p{sc=I<script>}> are unchanged. This should make
+programs be more accurate when determining if a character is used in a given
+script, but there is a slight chance of breakage for programs that very
+specifically needed the old behavior. See L<perlunicode/Scripts>.
+
+=head2 Declaring a reference to a variable
+
+As an experimental feature, Perl now allows the referencing operator to come
+after L<C<my()>|perlfunc/my>, L<C<state()>|perlfunc/state>,
+L<C<our()>|perlfunc/our>, or L<C<local()>|perlfunc/local>. This syntax must
+be enabled with C<use feature 'declared_refs'>. It is experimental, and will
+warn by default unless C<no warnings 'experimental::refaliasing'> is in effect.
+It is intended mainly for use in assignments to references. For example:
+
+ use experimental 'refaliasing', 'declared_refs';
+ my \$a = \$b;
+
+See L<perlref/Assigning to References> for slightly more detail.
+
+=head1 Incompatible Changes
+
+=head2 C<${^ENCODING}> has been removed
+
+Consequently, the L<encoding> pragma's default mode is no longer supported. If
+you still need to write your source code in encodings other than UTF-8, use a
+source filter such as L<Filter::Encoding> on CPAN or L<encoding>'s C<Filter>
+option.
+
+=head2 C<scalar(%hash)> return signature changed
+
+The value returned for C<scalar(%hash)> will no longer show information about
+the buckets allocated in the hash. It will simply return the count of used
+keys. It is thus equivalent to C<0+keys(%hash)>.
+
+A form of backwards compatibility is provided via C<Hash::Util::bucket_ratio()>
+which provides the same behavior as C<scalar(%hash)> provided prior to Perl
+5.25.
+
+=head1 Modules and Pragmata
+
+=head2 Updated Modules and Pragmata
+
+=over 4
+
+=item *
+
+L<bignum> has been upgraded from version 0.42 to 0.43.
+
+=item *
+
+L<Data::Dumper> has been upgraded from version 2.160 to 2.161.
+
+=item *
+
+L<Devel::PPPort> has been upgraded from version 3.32 to 3.35.
+
+=item *
+
+L<Encode> has been upgraded from version 2.80 to 2.84.
+
+=item *
+
+L<encoding> has been upgraded from version 2.17 to 2.17_01.
+
+This module's default mode is no longer supported as of Perl 5.25.3. It now
+dies when imported, unless the C<Filter> option is being used.
+
+=item *
+
+L<encoding::warnings> has been upgraded from version 0.12 to 0.13.
+
+This module is no longer supported as of Perl 5.25.3. It emits a warning to
+that effect and then does nothing.
+
+=item *
+
+L<ExtUtils::ParseXS> has been upgraded from version 3.32 to 3.33.
+
+=item *
+
+L<ExtUtils::Typemaps> has been upgraded from version 3.32 to 3.33.
+
+=item *
+
+L<feature> has been upgraded from version 1.44 to 1.45.
+
+=item *
+
+L<Hash::Util> has been upgraded from version 0.19 to 0.20.
+
+=item *
+
+L<Math::BigInt> has been upgraded from version 1.999715 to 1.999726.
+
+=item *
+
+L<Math::BigInt::FastCalc> has been upgraded from version 0.40 to 0.42.
+
+=item *
+
+L<Math::BigRat> has been upgraded from version 0.260802 to 0.260804.
+
+=item *
+
+L<Module::CoreList> has been upgraded from version 5.20160620 to 5.20160720.
+
+=item *
+
+L<Parse::CPAN::Meta> has been upgraded from version 1.4417 to 1.4422.
+
+=item *
+
+L<Perl::OSType> has been upgraded from version 1.009 to 1.010.
+
+=item *
+
+L<Test::Simple> has been upgraded from version 1.302026 to 1.302045.
+
+=item *
+
+L<Time::HiRes> has been upgraded from version 1.9734 to 1.9739.
+
+=item *
+
+L<Unicode::UCD> has been upgraded from version 0.65 to 0.66.
+
+=item *
+
+L<version> has been upgraded from version 0.9916 to 0.9917.
+
+=item *
+
+L<warnings> has been upgraded from version 1.36 to 1.37.
+
+=item *
+
+L<XSLoader> has been upgraded from version 0.21 to 0.22, fixing a security hole
+in which binary files could be loaded from a path outside of
+L<C<@INC>|perlvar/@INC>.
+
+=back
+
+=head1 Documentation
+
+=head2 Changes to Existing Documentation
+
+=head3 L<perldata> and L<perltie>
+
+=over 4
+
+=item *
+
+Updated documentation of C<scalar(%hash)>. See L</scalar(%hash) return
+signature changed> above.
+
+=back
+
+=head3 L<perlexperiment> and L<perlref>
+
+=over 4
+
+=item *
+
+Documented new feature: See L</Declaring a reference to a variable> above.
+
+=back
+
+=head3 L<perlfunc>
+
+=over 4
+
+=item *
+
+Clarified documentation of L<C<seek()>|perlfunc/seek>,
+L<C<tell()>|perlfunc/tell> and L<C<sysseek()>|perlfunc/sysseek>.
+L<[perl #128607]|https://rt.perl.org/Public/Bug/Display.html?id=128607>
+
+=item *
+
+Removed obsolete documentation of L<C<study()>|perlfunc/study>.
+
+=back
+
+=head3 L<perlunicode>
+
+=over 4
+
+=item *
+
+Documented change to C<\p{I<script>}> to now use the improved Script_Extensions
+property. See L</Use of \p{script} uses the improved Script_Extensions
+property> above.
+
+=item *
+
+Updated the text to correspond with changes in Unicode UTS#18, concerning
+regular expressions, and Perl compatibility with what it says.
+
+=back
+
+=head3 L<perlvar>
+
+=over 4
+
+=item *
+
+Removed obsolete documentation of C<${^ENCODING}>. See L</${^ENCODING} has
+been removed> above.
+
+=back
+
+=head1 Diagnostics
+
+The following additions or changes have been made to diagnostic output,
+including warnings and fatal error messages. For the complete list of
+diagnostic messages, see L<perldiag>.
+
+=head2 New Diagnostics
+
+=head3 New Errors
+
+=over 4
+
+=item *
+
+L<The experimental declared_refs feature is not enabled|perldiag/"The experimental declared_refs feature is not enabled">
+
+(F) To declare references to variables, as in C<my \%x>, you must first enable
+the feature:
+
+ no warnings "experimental::declared_refs";
+ use feature "declared_refs";
+
+=back
+
+=head3 New Warnings
+
+=over 4
+
+=item *
+
+L<Declaring references is experimental|perldiag/"Declaring references is experimental">
+
+(S experimental::declared_refs) This warning is emitted if you use a reference
+constructor on the right-hand side of C<my()>, C<state()>, C<our()>, or
+C<local()>. Simply suppress the warning if you want to use the feature, but
+know that in doing so you are taking the risk of using an experimental feature
+which may change or be removed in a future Perl version:
+
+ no warnings "experimental::declared_refs";
+ use feature "declared_refs";
+ $fooref = my \$foo;
+
+=item *
+
+L<C<${^ENCODING}> is no longer supported|perldiag/"${^ENCODING} is no longer supported">
+
+(D deprecated) The special variable C<${^ENCODING}>, formerly used to implement
+the C<encoding> pragma, is no longer supported as of Perl 5.26.0.
+
+=back
+
+=head1 Configuration and Compilation
+
+=over 4
+
+=item *
+
+F<Configure> now aborts if both "-Duselongdouble" and "-Dusequadmath" are
+requested.
+L<[perl #126203]|https://rt.perl.org/Public/Bug/Display.html?id=126203>
+
+=item *
+
+Fixed a bug in which F<Configure> could append "-quadmath" to the archname even
+if it was already present.
+L<[perl #128538]|https://rt.perl.org/Public/Bug/Display.html?id=128538>
+
+=item *
+
+Clang builds with "-DPERL_GLOBAL_STRUCT" or "-DPERL_GLOBAL_STRUCT_PRIVATE" have
+been fixed (by disabling Thread Safety Analysis for these configurations).
+
+=back
+
+=head1 Testing
+
+=over 4
+
+=item *
+
+A new test script, F<t/op/decl-refs.t>, has been added to test the new feature,
+"Declaring a reference to a variable".
+
+=item *
+
+A new test script, F<t/re/anyof.t>, has been added to test that the ANYOF nodes
+generated by bracketed character classes are as expected.
+
+=back
+
+=head1 Platform Support
+
+=head2 Platform-Specific Notes
+
+=over 4
+
+=item VAX
+
+VAX floating point formats are now supported.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
+
+=item *
+
+An assertion failure with C<%: = 0> has been fixed.
+L<[perl #128238]|https://rt.perl.org/Public/Bug/Display.html?id=128238>
+
+=item *
+
+In Perl 5.18, the parsing of C<"$foo::$bar"> was accidentally changed, such
+that it would be treated as C<$foo."::".$bar>. The previous behavior, which
+was to parse it as C<$foo:: . $bar>, has been restored.
+L<[perl #128478]|https://rt.perl.org/Public/Bug/Display.html?id=128478>
+
+=item *
+
+Since Perl 5.20, line numbers have been off by one when perl is invoked with
+the B<-x> switch. This has been fixed.
+L<[perl #128508]|https://rt.perl.org/Public/Bug/Display.html?id=128508>
+
+=item *
+
+Vivifying a subroutine stub in a deleted stash (e.g., C<delete $My::{"Foo::"};
+\&My::Foo::foo>) no longer crashes. It had begun crashing in Perl 5.18.
+L<[perl #128532]|https://rt.perl.org/Public/Bug/Display.html?id=128532>
+
+=item *
+
+Some obscure cases of subroutines and file handles being freed at the same time
+could result in crashes, but have been fixed. The crash was introduced in Perl
+5.22.
+L<[perl #128597]|https://rt.perl.org/Public/Bug/Display.html?id=128597>
+
+=item *
+
+Code that looks for a variable name associated with an uninitialized value
+could cause an assertion in cases where magic is involved, such as
+C<$ISA[0][0]>. This has now been fixed.
+L<[perl #128253]|https://rt.perl.org/Public/Bug/Display.html?id=128253>
+
+=item *
+
+A crash caused by code generating the warning "Subroutine STASH::NAME
+redefined" in cases such as C<sub P::f{} undef *P::; *P::f =sub{};> has been
+fixed. In these cases, where the STASH is missing, the warning will now appear
+as "Subroutine NAME redefined".
+L<[perl #128257]|https://rt.perl.org/Public/Bug/Display.html?id=128257>
+
+=item *
+
+Fixed an assertion triggered by some code that handles deprecated behavior in
+formats, e.g. in cases like this:
+
+ format STDOUT =
+ @
+ 0"$x"
+
+L<[perl #128255]|https://rt.perl.org/Public/Bug/Display.html?id=128255>
+
+=item *
+
+A possible divide by zero in string transformation code on Windows has been
+avoided, fixing a crash when collating an empty string.
+L<[perl #128618]|https://rt.perl.org/Public/Bug/Display.html?id=128618>
+
+=item *
+
+Some regular expression parsing glitches could lead to assertion failures with
+regular expressions such as C</(?<=/> and C</(?<!/>. This has now been fixed.
+L<[perl #128170]|https://rt.perl.org/Public/Bug/Display.html?id=128170>
+
+=back
+
+=head1 Errata From Previous Releases
+
+=over 4
+
+=item *
+
+Parsing bad POSIX charclasses no longer leaks memory. This was fixed in Perl
+5.25.2
+L<[perl #128313]|https://rt.perl.org/Public/Bug/Display.html?id=128313>
+
+=item *
+
+Fixed issues with recursive regexes. The behavior was fixed in Perl 5.24.0.
+L<[perl #126182]|https://rt.perl.org/Public/Bug/Display.html?id=126182>
+
+=back
+
+=head1 Acknowledgements
+
+Perl 5.25.3 represents approximately 4 weeks of development since Perl 5.25.2
+and contains approximately 67,000 lines of changes across 510 files from 25
+authors.
+
+Excluding auto-generated files, documentation and release tools, there were
+approximately 40,000 lines of changes to 290 .pm, .t, .c and .h files.
+
+Perl continues to flourish into its third decade thanks to a vibrant community
+of users and developers. The following people are known to have contributed
+the improvements that became Perl 5.25.3:
+
+Aaron Crane, Ævar Arnfjörð Bjarmason, Alex Vandiver, Aristotle Pagaltzis,
+Chad Granum, Chris 'BinGOs' Williams, Chris Lamb, Craig A. Berry, Dan Collins,
+David Mitchell, Father Chrysostomos, H.Merijn Brand, Jarkko Hietaniemi, Karl
+Williamson, Lukas Mai, Matthew Horsfall, Salvador Fandiño, Sawyer X,
+Sébastien Aperghis-Tramoni, Steffen Müller, Steve Hay, Todd Rinaldo, Tony
+Cook, Unicode Consortium, Yves Orton.
+
+The list above is almost certainly incomplete as it is automatically generated
+from version control history. In particular, it does not include the names of
+the (very much appreciated) contributors who reported issues to the Perl bug
+tracker.
+
+Many of the changes included in this version originated in the CPAN modules
+included in Perl's core. We're grateful to the entire CPAN community for
+helping Perl to flourish.
+
+For a more complete list of all of Perl's historical contributors, please see
+the F<AUTHORS> file in the Perl source distribution.
+
+=head1 Reporting Bugs
+
+If you find what you think is a bug, you might check the perl bug database at
+L<https://rt.perl.org/> . There may also be information at
+L<http://www.perl.org/> , the Perl Home Page.
+
+If you believe you have an unreported bug, please run the L<perlbug> program
+included with your release. Be sure to trim your bug down to a tiny but
+sufficient test case. Your bug report, along with the output of C<perl -V>,
+will be sent off to perlbug@perl.org to be analysed by the Perl porting team.
+
+If the bug you are reporting has security implications which make it
+inappropriate to send to a publicly archived mailing list, then see
+L<perlsec/SECURITY VULNERABILITY CONTACT INFORMATION> for details of how to
+report the issue.
+
+=head1 SEE ALSO
+
+The F<Changes> file for an explanation of how to view exhaustive details on
+what changed.
+
+The F<INSTALL> file for how to build Perl.
+
+The F<README> file for general stuff.
+
+The F<Artistic> and F<Copying> files for copyright information.
+
+=cut
static void
call_PrintList()
{
- dSP;
-
call_argv("PrintList", G_DISCARD, words);
}
=head1 NAME
-perldelta - what is new for perl v5.25.3
+perldelta - what is new for perl v5.25.4
=head1 DESCRIPTION
-This document describes differences between the 5.25.2 release and the 5.25.3
+This document describes differences between the 5.25.3 release and the 5.25.4
release.
-If you are upgrading from an earlier release such as 5.25.1, first read
-L<perl5252delta>, which describes differences between 5.25.1 and 5.25.2.
+If you are upgrading from an earlier release such as 5.25.2, first read
+L<perl5253delta>, which describes differences between 5.25.2 and 5.25.3.
-=head1 Core Enhancements
+=head1 Performance Enhancements
-=head2 Unicode 9.0 is now supported
-
-A list of changes is at L<http://www.unicode.org/versions/Unicode9.0.0/>.
-Modules that are shipped with core Perl but not maintained by p5p do not
-necessarily support Unicode 9.0. L<Unicode::Normalize> does work on 9.0.
-
-=head2 Use of C<\p{I<script>}> uses the improved Script_Extensions property
-
-Unicode 6.0 introduced an improved form of the Script (C<sc>) property, and
-called it Script_Extensions (C<scx>). As of now, Perl uses this improved
-version when a property is specified as just C<\p{I<script>}>. The meaning of
-compound forms, like C<\p{sc=I<script>}> are unchanged. This should make
-programs be more accurate when determining if a character is used in a given
-script, but there is a slight chance of breakage for programs that very
-specifically needed the old behavior. See L<perlunicode/Scripts>.
+=over 4
-=head2 Declaring a reference to a variable
+=item *
-As an experimental feature, Perl now allows the referencing operator to come
-after L<C<my()>|perlfunc/my>, L<C<state()>|perlfunc/state>,
-L<C<our()>|perlfunc/our>, or L<C<local()>|perlfunc/local>. This syntax must
-be enabled with C<use feature 'declared_refs'>. It is experimental, and will
-warn by default unless C<no warnings 'experimental::refaliasing'> is in effect.
-It is intended mainly for use in assignments to references. For example:
+The rather slow implementation for the experimental subroutine signatures
+feature has been made much faster; it is now comparable in speed with the
+old-style C<my ($a, $b, @c) = @_>.
- use experimental 'refaliasing', 'declared_refs';
- my \$a = \$b;
+=back
-See L<perlref/Assigning to References> for slightly more detail.
+=head1 Documentation
-=head1 Incompatible Changes
+=head2 Changes to Existing Documentation
-=head2 C<${^ENCODING}> has been removed
+=head3 L<perlcall>
-Consequently, the L<encoding> pragma's default mode is no longer supported. If
-you still need to write your source code in encodings other than UTF-8, use a
-source filter such as L<Filter::Encoding> on CPAN or L<encoding>'s C<Filter>
-option.
+=over 4
-=head2 C<scalar(%hash)> return signature changed
+=item *
-The value returned for C<scalar(%hash)> will no longer show information about
-the buckets allocated in the hash. It will simply return the count of used
-keys. It is thus equivalent to C<0+keys(%hash)>.
+Removed redundant C<dSP> from an example.
-A form of backwards compatibility is provided via C<Hash::Util::bucket_ratio()>
-which provides the same behavior as C<scalar(%hash)> provided prior to Perl
-5.25.
+=back
=head1 Modules and Pragmata
=item *
-L<bignum> has been upgraded from version 0.42 to 0.43.
+L<Archive::Tar> has been upgraded from version 2.08 to 2.10.
=item *
-L<Data::Dumper> has been upgraded from version 2.160 to 2.161.
+L<arybase> has been upgraded from version 0.11 to 0.12.
=item *
-L<Devel::PPPort> has been upgraded from version 3.32 to 3.35.
+L<B> has been upgraded from version 1.62 to 1.63.
=item *
-L<Encode> has been upgraded from version 2.80 to 2.84.
+L<B::Concise> has been upgraded from version 0.996 to 0.998.
=item *
-L<encoding> has been upgraded from version 2.17 to 2.17_01.
-
-This module's default mode is no longer supported as of Perl 5.25.3. It now
-dies when imported, unless the C<Filter> option is being used.
+L<B::Deparse> has been upgraded from version 1.37 to 1.38.
=item *
-L<encoding::warnings> has been upgraded from version 0.12 to 0.13.
-
-This module is no longer supported as of Perl 5.25.3. It emits a warning to
-that effect and then does nothing.
+L<base> has been upgraded from version 2.23 to 2.24.
=item *
-L<ExtUtils::ParseXS> has been upgraded from version 3.32 to 3.33.
+L<bignum> has been upgraded from version 0.43 to 0.43_01.
=item *
-L<ExtUtils::Typemaps> has been upgraded from version 3.32 to 3.33.
+L<Carp> has been upgraded from version 1.41 to 1.42.
=item *
-L<feature> has been upgraded from version 1.44 to 1.45.
+L<Config::Perl::V> has been upgraded from version 0.26 to 0.27.
=item *
-L<Hash::Util> has been upgraded from version 0.19 to 0.20.
+L<CPAN> has been upgraded from version 2.14 to 2.14_01.
=item *
-L<Math::BigInt> has been upgraded from version 1.999715 to 1.999726.
+L<CPAN::Meta> has been upgraded from version 2.150005 to 2.150010.
=item *
-L<Math::BigInt::FastCalc> has been upgraded from version 0.40 to 0.42.
+L<Digest> has been upgraded from version 1.17 to 1.17_01.
=item *
-L<Math::BigRat> has been upgraded from version 0.260802 to 0.260804.
+L<Digest::SHA> has been upgraded from version 5.95 to 5.96.
=item *
-L<Module::CoreList> has been upgraded from version 5.20160620 to 5.20160720.
+L<Encode> has been upgraded from version 2.84 to 2.86.
=item *
-L<Parse::CPAN::Meta> has been upgraded from version 1.4417 to 1.4422.
+L<encoding> has been upgraded from version 2.17_01 to 2.18.
=item *
-L<Perl::OSType> has been upgraded from version 1.009 to 1.010.
+L<Errno> has been upgraded from version 1.25 to 1.26.
=item *
-L<Test::Simple> has been upgraded from version 1.302026 to 1.302045.
+L<ExtUtils::MakeMaker> has been upgraded from version 7.18 to 7.24.
=item *
-L<Time::HiRes> has been upgraded from version 1.9734 to 1.9739.
+L<File::Fetch> has been upgraded from version 0.48 to 0.52.
=item *
-L<Unicode::UCD> has been upgraded from version 0.65 to 0.66.
+L<File::Spec> has been upgraded from version 3.64 to 3.65.
=item *
-L<version> has been upgraded from version 0.9916 to 0.9917.
+L<Hash::Util> has been upgraded from version 0.20 to 0.21.
=item *
-L<warnings> has been upgraded from version 1.36 to 1.37.
+L<HTTP::Tiny> has been upgraded from version 0.058 to 0.064.
=item *
-L<XSLoader> has been upgraded from version 0.21 to 0.22, fixing a security hole
-in which binary files could be loaded from a path outside of
-L<C<@INC>|perlvar/@INC>.
-
-=back
-
-=head1 Documentation
-
-=head2 Changes to Existing Documentation
-
-=head3 L<perldata> and L<perltie>
-
-=over 4
+L<I18N::LangTags> has been upgraded from version 0.40 to 0.41.
=item *
-Updated documentation of C<scalar(%hash)>. See L</scalar(%hash) return
-signature changed> above.
-
-=back
-
-=head3 L<perlexperiment> and L<perlref>
-
-=over 4
+L<IO> has been upgraded from version 1.36 to 1.37.
=item *
-Documented new feature: See L</Declaring a reference to a variable> above.
+L<IO-Compress> has been upgraded from version 2.069 to 2.069_01.
-=back
+=item *
-=head3 L<perlfunc>
-
-=over 4
+L<IO::Socket::IP> has been upgraded from version 0.37 to 0.38.
=item *
-Clarified documentation of L<C<seek()>|perlfunc/seek>,
-L<C<tell()>|perlfunc/tell> and L<C<sysseek()>|perlfunc/sysseek>.
-L<[perl #128607]|https://rt.perl.org/Public/Bug/Display.html?id=128607>
+L<IPC::Cmd> has been upgraded from version 0.94 to 0.96.
=item *
-Removed obsolete documentation of L<C<study()>|perlfunc/study>.
+L<JSON::PP> has been upgraded from version 2.27400 to 2.27400_01.
-=back
-
-=head3 L<perlunicode>
+=item *
-=over 4
+L<Locale::Maketext> has been upgraded from version 1.27 to 1.28.
=item *
-Documented change to C<\p{I<script>}> to now use the improved Script_Extensions
-property. See L</Use of \p{script} uses the improved Script_Extensions
-property> above.
+L<Locale::Maketext::Simple> has been upgraded from version 0.21 to 0.21_01.
=item *
-Updated the text to correspond with changes in Unicode UTS#18, concerning
-regular expressions, and Perl compatibility with what it says.
-
-=back
+L<Memoize> has been upgraded from version 1.03 to 1.03_01.
-=head3 L<perlvar>
+=item *
-=over 4
+L<Module::CoreList> has been upgraded from version 5.20160720 to 5.20160820.
=item *
-Removed obsolete documentation of C<${^ENCODING}>. See L</${^ENCODING} has
-been removed> above.
+L<Module::Load::Conditional> has been upgraded from version 0.64 to 0.68.
-=back
+=item *
-=head1 Diagnostics
+L<Module::Metadata> has been upgraded from version 1.000032 to 1.000033.
-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>.
+=item *
-=head2 New Diagnostics
+L<Net::Ping> has been upgraded from version 2.43 to 2.44.
-=head3 New Errors
+=item *
-=over 4
+L<NEXT> has been upgraded from version 0.65 to 0.67.
=item *
-L<The experimental declared_refs feature is not enabled|perldiag/"The experimental declared_refs feature is not enabled">
-
-(F) To declare references to variables, as in C<my \%x>, you must first enable
-the feature:
+L<Opcode> has been upgraded from version 1.35 to 1.37.
- no warnings "experimental::declared_refs";
- use feature "declared_refs";
+=item *
-=back
+L<Pod::Html> has been upgraded from version 1.22 to 1.2201.
-=head3 New Warnings
+=item *
-=over 4
+L<Pod::Perldoc> has been upgraded from version 3.25_02 to 3.27.
=item *
-L<Declaring references is experimental|perldiag/"Declaring references is experimental">
+L<POSIX> has been upgraded from version 1.70 to 1.71.
-(S experimental::declared_refs) This warning is emitted if you use a reference
-constructor on the right-hand side of C<my()>, C<state()>, C<our()>, or
-C<local()>. Simply suppress the warning if you want to use the feature, but
-know that in doing so you are taking the risk of using an experimental feature
-which may change or be removed in a future Perl version:
+=item *
- no warnings "experimental::declared_refs";
- use feature "declared_refs";
- $fooref = my \$foo;
+L<Storable> has been upgraded from version 2.56 to 2.57.
=item *
-L<C<${^ENCODING}> is no longer supported|perldiag/"${^ENCODING} is no longer supported">
+L<Sys::Syslog> has been upgraded from version 0.34 to 0.34_01.
-(D deprecated) The special variable C<${^ENCODING}>, formerly used to implement
-the C<encoding> pragma, is no longer supported as of Perl 5.26.0.
+=item *
-=back
+L<Test> has been upgraded from version 1.28 to 1.29.
-=head1 Configuration and Compilation
+=item *
-=over 4
+L<Test::Harness> has been upgraded from version 3.36 to 3.36_01.
=item *
-F<Configure> now aborts if both "-Duselongdouble" and "-Dusequadmath" are
-requested.
-L<[perl #126203]|https://rt.perl.org/Public/Bug/Display.html?id=126203>
+L<Test::Simple> has been upgraded from version 1.302045 to 1.302052.
=item *
-Fixed a bug in which F<Configure> could append "-quadmath" to the archname even
-if it was already present.
-L<[perl #128538]|https://rt.perl.org/Public/Bug/Display.html?id=128538>
+L<Tie::Hash::NamedCapture> has been upgraded from version 0.09 to 0.10.
=item *
-Clang builds with "-DPERL_GLOBAL_STRUCT" or "-DPERL_GLOBAL_STRUCT_PRIVATE" have
-been fixed (by disabling Thread Safety Analysis for these configurations).
+L<Time::Local> has been upgraded from version 1.2300 to 1.24.
=back
-=head1 Testing
+=head1 Configuration and Compilation
=over 4
=item *
-A new test script, F<t/op/decl-refs.t>, has been added to test the new feature,
-"Declaring a reference to a variable".
-
-=item *
-
-A new test script, F<t/re/anyof.t>, has been added to test that the ANYOF nodes
-generated by bracketed character classes are as expected.
+A probe for C<gai_strerror> was added to F<Configure> that checks if the
+the gai_strerror() routine is available and can be used to
+translate error codes returned by getaddrinfo() into human
+readable strings.
=back
=over 4
-=item VAX
+=item Hurd
-VAX floating point formats are now supported.
+The hints for Hurd have been improved enabling malloc wrap and reporting the
+GNU libc used (previously it was an empty string when reported).
=back
-=head1 Selected Bug Fixes
+=head1 Internal Changes
=over 4
=item *
-An assertion failure with C<%: = 0> has been fixed.
-L<[perl #128238]|https://rt.perl.org/Public/Bug/Display.html?id=128238>
+Three new ops, C<OP_ARGELEM>, C<OP_ARGDEFELEM> and C<OP_ARGCHECK> have
+been added. These are intended principally to implement the individual
+elements of a subroutine signature, plus any overall checking required.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
=item *
-In Perl 5.18, the parsing of C<"$foo::$bar"> was accidentally changed, such
-that it would be treated as C<$foo."::".$bar>. The previous behavior, which
-was to parse it as C<$foo:: . $bar>, has been restored.
-L<[perl #128478]|https://rt.perl.org/Public/Bug/Display.html?id=128478>
+Problems with in-place array sorts: code like C<@a = sort { ... } @a>,
+where the source and destination of the sort are the same plain array, are
+optimised to do less copying around. Two side-effects of this optimisation
+were that the contents of C<@a> as visible to to sort routine were
+partially sorted, and under some circumstances accessing C<@a> during the
+sort could crash the interpreter. Both these issues have been fixed, and
+Sort functions see the original value of C<@a>.
=item *
-Since Perl 5.20, line numbers have been off by one when perl is invoked with
-the B<-x> switch. This has been fixed.
-L<[perl #128508]|https://rt.perl.org/Public/Bug/Display.html?id=128508>
+Non-ASCII string delimiters are now reported correctly in error messages
+for unterminated strings. [perl #128701]
=item *
-Vivifying a subroutine stub in a deleted stash (e.g., C<delete $My::{"Foo::"};
-\&My::Foo::foo>) no longer crashes. It had begun crashing in Perl 5.18.
-L<[perl #128532]|https://rt.perl.org/Public/Bug/Display.html?id=128532>
+C<pack("p", ...)> used to emit its warning ("Attempt to pack pointer to
+temporary value") erroneously in some cases, but has been fixed.
=item *
-Some obscure cases of subroutines and file handles being freed at the same time
-could result in crashes, but have been fixed. The crash was introduced in Perl
-5.22.
-L<[perl #128597]|https://rt.perl.org/Public/Bug/Display.html?id=128597>
+C<@DB::args> is now exempt from "used once" warnings. The warnings only
+occurred under B<-w>, because F<warnings.pm> itself uses C<@DB::args>
+multiple times.
=item *
-Code that looks for a variable name associated with an uninitialized value
-could cause an assertion in cases where magic is involved, such as
-C<$ISA[0][0]>. This has now been fixed.
-L<[perl #128253]|https://rt.perl.org/Public/Bug/Display.html?id=128253>
+The use of built-in arrays or hash slices in a double-quoted string no
+longer issues a warning ("Possible unintended interpolation...") if the
+variable has not been mentioned before. This affected code like
+C<qq|@DB::args|> and C<qq|@SIG{'CHLD', 'HUP'}|>. (The special variables
+C<@-> and C<@+> were already exempt from the warning.)
=item *
-A crash caused by code generating the warning "Subroutine STASH::NAME
-redefined" in cases such as C<sub P::f{} undef *P::; *P::f =sub{};> has been
-fixed. In these cases, where the STASH is missing, the warning will now appear
-as "Subroutine NAME redefined".
-L<[perl #128257]|https://rt.perl.org/Public/Bug/Display.html?id=128257>
+C<gethostent> and similar functions now perform a null check internally, to
+avoid crashing with torsocks. This was a regression from 5.22. [perl
+#128740]
=item *
-Fixed an assertion triggered by some code that handles deprecated behavior in
-formats, e.g. in cases like this:
+C<defined *{'!'}>, C<defined *{'['}>, and C<defined *{'-'}> no longer leak
+memory if the typeglob in question has never been accessed before.
- format STDOUT =
- @
- 0"$x"
+=item *
-L<[perl #128255]|https://rt.perl.org/Public/Bug/Display.html?id=128255>
+In 5.25.4 fchown() was changed not to accept negative one as an argument
+because in some platforms that is an error. However, in some other platforms
+that is an acceptable argument. This change has been reverted [perl #128967].
=item *
-A possible divide by zero in string transformation code on Windows has been
-avoided, fixing a crash when collating an empty string.
-L<[perl #128618]|https://rt.perl.org/Public/Bug/Display.html?id=128618>
+Mentioning the same constant twice in a row (which is a syntax error) no
+longer fails an assertion under debugging builds. This was a regression
+from 5.20. [perl #126482]
=item *
-Some regular expression parsing glitches could lead to assertion failures with
-regular expressions such as C</(?<=/> and C</(?<!/>. This has now been fixed.
-L<[perl #128170]|https://rt.perl.org/Public/Bug/Display.html?id=128170>
+Many issues relating to C<printf "%a"> of hexadecimal floating point
+were fixed. In addition, the "subnormals" (formerly known as "denormals")
+floating point anumbers are now supported both with the plain IEEE 754
+floating point numbers (64-bit or 128-bit) and the x86 80-bit
+"extended precision". Note that subnormal hexadecimal floating
+point literals will give a warning about "exponent underflow".
+[perl #128843, #128889, #128890, #128893, #128909, #128919]
-=back
+=item *
-=head1 Errata From Previous Releases
+A regression in 5.24 with C<tr/\N{U+...}/foo/> when the code point was between
+128 and 255 has been fixed. [perl #128734].
-=over 4
+=item *
+
+A regression from the previous development release, 5.23.3, where
+compiling a regular expression could crash the interpreter has been
+fixed. [perl #128686].
=item *
-Parsing bad POSIX charclasses no longer leaks memory. This was fixed in Perl
-5.25.2
-L<[perl #128313]|https://rt.perl.org/Public/Bug/Display.html?id=128313>
+Use of a string delimiter whose code point is above 2**31 now works
+correctly on platforms that allow this. Previously, certain characters,
+due to truncation, would be confused with other delimiter characters
+with special meaning (such as C<?> in C<m?...?>), resulting
+in inconsistent behaviour. Note that this is non-portable,
+and is based on Perl's extension to UTF-8, and is probably not
+displayable nor enterable by any editor. [perl #128738]
=item *
-Fixed issues with recursive regexes. The behavior was fixed in Perl 5.24.0.
-L<[perl #126182]|https://rt.perl.org/Public/Bug/Display.html?id=126182>
+C<@{x> followed by a newline where C<x> represents a control or non-ASCII
+character no longer produces a garbled syntax error message or a crash.
+[perl #128951]
=back
=head1 Acknowledgements
-Perl 5.25.3 represents approximately 4 weeks of development since Perl 5.25.2
-and contains approximately 67,000 lines of changes across 510 files from 25
+Perl 5.25.4 represents approximately 4 weeks of development since Perl 5.25.3
+and contains approximately 18,000 lines of changes across 820 files from 23
authors.
Excluding auto-generated files, documentation and release tools, there were
-approximately 40,000 lines of changes to 290 .pm, .t, .c and .h files.
+approximately 9,200 lines of changes to 660 .pm, .t, .c and .h files.
Perl continues to flourish into its third decade thanks to a vibrant community
-of users and developers. The following people are known to have contributed
-the improvements that became Perl 5.25.3:
+of users and developers. The following people are known to have contributed the
+improvements that became Perl 5.25.4:
-Aaron Crane, Ævar Arnfjörð Bjarmason, Alex Vandiver, Aristotle Pagaltzis,
-Chad Granum, Chris 'BinGOs' Williams, Chris Lamb, Craig A. Berry, Dan Collins,
-David Mitchell, Father Chrysostomos, H.Merijn Brand, Jarkko Hietaniemi, Karl
-Williamson, Lukas Mai, Matthew Horsfall, Salvador Fandiño, Sawyer X,
-Sébastien Aperghis-Tramoni, Steffen Müller, Steve Hay, Todd Rinaldo, Tony
-Cook, Unicode Consortium, Yves Orton.
+Chris 'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari Mannsåker, Dan
+Collins, Daniel Dragan, David Mitchell, Father Chrysostomos, H.Merijn Brand,
+James E Keenan, Jarkko Hietaniemi, Karen Etheridge, Karl Williamson, Lukas Mai,
+Neil Bowers, Nicolas R., Pino Toscano, Rafael Garcia-Suarez, Richard Levitte,
+Shlomi Fish, Smylers, 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
+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
+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
=head1 Reporting Bugs
-If you find what you think is a bug, you might check the perl bug database at
-L<https://rt.perl.org/> . There may also be information at
+If you find what you think is a bug, you might check the perl bug database
+at L<https://rt.perl.org/> . There may also be information at
L<http://www.perl.org/> , the Perl Home Page.
If you believe you have an unreported bug, please run the L<perlbug> program
If the bug you are reporting has security implications which make it
inappropriate to send to a publicly archived mailing list, then see
-L<perlsec/SECURITY VULNERABILITY CONTACT INFORMATION> for details of how to
-report the issue.
+L<perlsec/SECURITY VULNERABILITY CONTACT INFORMATION>
+for details of how to report the issue.
=head1 SEE ALSO
(W syntax) You called stat() on an array, but the array will be
coerced to a scalar - the number of elements in the array.
+=item A signature parameter must start with '$', '@' or '%'
+
+(F) Each subroutine signature parameter declaration must start with a valid
+sigil; for example:
+
+ sub foo ($a, $, $b = 1, @c) {}
+
+=item A slurpy parameter may not have a default value
+
+(F) Only scalar subroutine signature parameters may have a default value;
+for example:
+
+ sub foo ($a = 1) {} # legal
+ sub foo (@a = (1)) {} # invalid
+ sub foo (%a = (a => b)) {} # invalid
+
=item assertion botched: %s
(X) The malloc package that comes with Perl had an internal failure.
=item Bareword in require maps to empty filename
(F) The bareword form of require has been invoked with a filename which could
-not have been generated by a valid bareword permitted by the parser. You
+not have been generated by a valid bareword permitted by the parser. You
shouldn't be able to get this error from Perl code, but XS code may throw it
if it passes an invalid module name to C<Perl_load_module>.
=item Bareword in require must not start with a double-colon: "%s"
(F) In C<require Bare::Word>, the bareword is not allowed to start with a
-double-colon. Write C<require ::Foo::Bar> as C<require Foo::Bar> instead.
+double-colon. Write C<require ::Foo::Bar> as C<require Foo::Bar> instead.
=item Bareword "%s" not allowed while "strict subs" in use
(F) Some XS code tried to use C<sv_catpvfn()> or a related function with a
format string that specifies explicit indexes for some of the elements, and
-using a C-style variable-argument list (a C<va_list>). This is not currently
-supported. XS authors wanting to do this must instead construct a C array of
-C<SV*> scalars containing the arguments.
+using a C-style variable-argument list (a C<va_list>). This is not currently
+supported. XS authors wanting to do this must instead construct a C array
+of C<SV*> scalars containing the arguments.
=item Can only compress unsigned integers in pack
=item Hexadecimal float: exponent underflow
(W overflow) The hexadecimal floating point has a smaller exponent
-than the floating point supports.
+than the floating point supports. With the IEEE 754 floating point,
+this may also mean that the subnormals (formerly known as denormals)
+are being used, which may or may not be an error.
=item Hexadecimal float: internal error (%s)
=item Illegal character \%o (carriage return)
-(F) Perl normally treats carriage returns in the program text as it
-would any other whitespace, which means you should never see this error
-when Perl was built using standard options. For some reason, your
-version of Perl appears to have been built without this support. Talk
-to your Perl administrator.
+(F) Perl normally treats carriage returns in the program text as
+it would any other whitespace, which means you should never see
+this error when Perl was built using standard options. For some
+reason, your version of Perl appears to have been built without
+this support. Talk to your Perl administrator.
+
+=item Illegal character following sigil in a subroutine signature
+
+(F) A parameter in a subroutine signature contained an unexpected character
+following the C<$>, C<@> or C<%> sigil character. Normally the sigil
+should be followed by the variable name or C<=> etc. Perhaps you are
+trying use a prototype while in the scope of C<use feature 'signatures'>?
+For example:
+
+ sub foo ($$) {} # legal - a prototype
+
+ use feature 'signatures;
+ sub foo ($$) {} # illegal - was expecting a signature
+ sub foo ($a, $b)
+ :prototype($$) {} # legal
+
=item Illegal character in prototype for %s : %s
=item Initialization of state variables in list context currently forbidden
-(F) Currently the implementation of "state" only permits the
-initialization of scalar variables in scalar context. Re-write
-C<state ($a) = 42> as C<state $a = 42> to change from list to scalar
-context. Constructions such as C<state (@a) = foo()> will be
-supported in a future perl release.
+(F) C<state> only permits initializing a single scalar variable, in scalar
+context. So C<state $a = 42> is allowed, but not C<state ($a) = 42>. To apply
+state semantics to a hash or array, store a hash or array reference in a
+scalar variable.
=item %%s[%s] in scalar context better written as $%s[%s]
(W syntax) Multidimensional arrays aren't written like C<$foo[1,2,3]>.
They're written like C<$foo[1][2][3]>, as in C.
+=item Multiple slurpy parameters not allowed
+
+(F) In subroutine signatures, a slurpy parameter (C<@> or C<%>) must be
+the last parameter, and there must not be more than one of them; for
+example:
+
+ sub foo ($a, @b) {} # legal
+ sub foo ($a, @b, %) {} # invalid
+
=item '/' must follow a numeric type in unpack
(F) You had an unpack template that contained a '/', but this did not
reference to something else instead. You can use the ref() function to
find out what kind of ref it really was. See L<perlref>.
+=item '#' not allowed immediately following a sigil in a subroutine signature
+
+(F) In a subroutine signature definition, a comment following a sigil
+(C<$>, C<@> or C<%>), needs to be separated by whitespace or a commma etc., in
+particular to avoid confusion with the C<$#> variable. For example:
+
+ # bad
+ sub f ($# ignore first arg
+ , $b) {}
+ # good
+ sub f ($, # ignore first arg
+ $b) {}
+
=item Not an ARRAY reference
(F) Perl was trying to evaluate a reference to an array value, but found
thrown.
You are recommended to change your code to set C<$/> to C<undef> explicitly
-if you wish to slurp the file. In future versions of Perl assigning
+if you wish to slurp the file. In future versions of Perl assigning
a reference to will throw a fatal error.
=item Setting $/ to %s reference is forbidden
=item Too few arguments for subroutine
-(F) A subroutine using a signature received fewer arguments than required
-by the signature. The caller of the subroutine is presumably at fault.
-Inconveniently, this error will be reported at the location of the
-subroutine, not that of the caller.
+(F) A subroutine using a signature received too few arguments than
+required by the signature. The caller of the subroutine is presumably
+at fault.
=item Too late for "-%s" option
=item Too many arguments for subroutine
-(F) A subroutine using a signature received more arguments than required
-by the signature. The caller of the subroutine is presumably at fault.
-Inconveniently, this error will be reported at the location of the
-subroutine, not that of the caller.
+(F) A subroutine using a signature received too many arguments than
+required by the signature. The caller of the subroutine is presumably
+at fault.
+
=item Too many )'s
largest possible ones break the perl interpreter in some constructs,
including causing it to hang in a few cases. The known problem areas
are in C<tr///>, regular expression pattern matching using quantifiers,
-and as the upper limits in loops.
+as quote delimiters in C<qI<X>...I<X>> (where I<X> is the C<chr()> of a large
+code point), and as the upper limits in loops.
+There may be other breakages as well. If you get this warning, and
+things aren't working correctly, you probably have found one of these.
If your code is to run on various platforms, keep in mind that the upper
limit depends on the platform. It is much larger on 64-bit word sizes
=item Version control conflict marker
(F) The parser found a line starting with C<E<lt><<<<<<>,
-C<E<gt>E<gt>E<gt>E<gt>E<gt>E<gt>E<gt>>, or C<=======>. These may be left by a
+C<E<gt>E<gt>E<gt>E<gt>E<gt>E<gt>E<gt>>, or C<=======>. These may be left by a
version control system to mark conflicts after a failed merge operation.
=item Version number must be a constant number
Because various errors may only be detected by close() (e.g. buffering could
allow the C<print> in this example to return true even when the disk is full),
-it is dangerous to ignore its result. So when it happens implicitly, perl will
-signal errors by warning.
+it is dangerous to ignore its result. So when it happens implicitly, perl
+will signal errors by warning.
B<Prior to version 5.22.0, perl ignored such errors>, so the common idiom shown
above was liable to cause B<silent data loss>.
Returns the offset of where the last C<m//g> search left off for the
variable in question (L<C<$_>|perlvar/$_> is used when the variable is not
-specified). Note that 0 is a valid match offset.
+specified). This offset is in characters unless the
+(no-longer-recommended) L<C<use bytes>|bytes> pragma is in effect, in
+which case the offset is in bytes. Note that 0 is a valid match offset.
L<C<undef>|/undef EXPR> indicates
that the search position is reset (usually due to match failure, but
can also be because no match has yet been run on the scalar).
If you are printing addresses of pointers, use UVxf combined
with PTR2UV(), do not use %lx or %p.
+=head2 Formatted Printing of Size_t and SSize_t
+
+The most general way to do this is to cast them to a UV or IV, and
+print as in the
+L<previous section|/Formatted Printing of IVs, UVs, and NVs>.
+
+But if you're using C<PerlIO_printf()>, it's less typing and visual
+clutter to use the C<"%z"> length modifier (for I<siZe>):
+
+ PerlIO_printf("STRLEN is %zu\n", len);
+
+This modifier is not portable, so its use should be restricted to
+C<PerlIO_printf()>.
+
=head2 Pointer-To-Integer and Integer-To-Pointer
Because pointer size does not necessarily equal integer size,
printf("i = %"IVdf"\n", (IV)something_very_small_and_signed);
+See L<perlguts/Formatted Printing of Size_t and SSize_t> for how to
+print those.
+
Also remember that the C<%p> format really does require a void pointer:
U8* p = ...;
To really poke around with Perl, you'll probably want to build Perl for
debugging, like this:
- ./Configure -d -D optimize=-g
+ ./Configure -d -DDEBUGGING
make
-C<-g> is a flag to the C compiler to have it produce debugging
-information which will allow us to step through a running program, and
-to see in which C function we are at (without the debugging information
-we might see only the numerical addresses of the functions, which is
-not very helpful).
-
-F<Configure> will also turn on the C<DEBUGGING> compilation symbol
-which enables all the internal debugging code in Perl. There are a
-whole bunch of things you can debug with this: L<perlrun> lists them
-all, and the best way to find out about them is to play about with
-them. The most useful options are probably
+C<-DDEBUGGING> turns on the C compiler's C<-g> flag to have it produce
+debugging information which will allow us to step through a running
+program, and to see in which C function we are at (without the debugging
+information we might see only the numerical addresses of the functions,
+which is not very helpful). It will also turn on the C<DEBUGGING>
+compilation symbol which enables all the internal debugging code in Perl.
+There are a whole bunch of things you can debug with this: L<perlrun>
+lists them all, and the best way to find out about them is to play about
+with them. The most useful options are probably
l Context (loop) stack processing
+ s Stack snapshots (with v, displays all stacks)
t Trace execution
o Method and overloading resolution
c String/numeric conversions
-Some of the functionality of the debugging code can be achieved using
-XS modules.
+For example
+
+ $ perl -Dst -e '$a + 1'
+ ....
+ (-e:1) gvsv(main::a)
+ => UNDEF
+ (-e:1) const(IV(1))
+ => UNDEF IV(1)
+ (-e:1) add
+ => NV(1)
+
+
+Some of the functionality of the debugging code can be achieved with a
+non-debugging perl by using XS modules:
-Dr => use re 'debug'
-Dx => use O 'Debug'
Steve 5.22.2-RC1 2016-Apr-10
Steve 5.22.2 2016-Apr-29
Steve 5.22.3-RC1 2016-Jul-17
+ Steve 5.22.3-RC2 2016-Jul-25
+ Steve 5.22.3-RC3 2016-Aug-11
Ricardo 5.23.0 2015-Jun-20 The 5.23 development track
Matthew 5.23.1 2015-Jul-20
Ricardo 5.24.0-RC5 2016-May-04
Ricardo 5.24.0 2016-May-09
Steve 5.24.1-RC1 2016-Jul-17
+ Steve 5.24.1-RC2 2016-Jul-25
+ Steve 5.24.1-RC3 2016-Aug-11
Ricardo 5.25.0 2016-May-09 The 5.25 development track
Sawyer X 5.25.1 2016-May-20
Matthew 5.25.2 2016-Jun-20
Steve 5.25.3 2016-Jul-20
+ BinGOs 5.25.4 2016-Aug-20
=head2 SELECTED RELEASE SIZES
11 SVOP (0x816dcf0) gv GV (0x80fa460) *a
That is, fetch the C<a> entry from the main symbol table, and then look
-at the scalar component of it: C<gvsv> (C<pp_gvsv> in
to F<pp_hot.c>)
+at the scalar component of it: C<gvsv> (C<pp_gvsv> in F<pp_hot.c>)
happens to do both these things.
The right hand side, starting at line 5 is similar to what we've just
-seen: we have the C<add> op (C<pp_add> also in F<pp_hot.c>) add
+seen: we have the C<add> op (C<pp_add>
, also in F<pp_hot.c>) add
together two C<gvsv>s.
Now, what's this about?
A character range may be specified with a hyphen, so C<tr/A-J/0-9/>
does the same replacement as C<tr/ACEGIBDFHJ/0246813579/>.
For B<sed> devotees, C<y> is provided as a synonym for C<tr>. If the
-I<SEARCHLIST> is delimited by bracketing quotes, the I<REPLACEMENTLIST> has
-its own pair of quotes, which may or may not be bracketing quotes;
-for example, C<tr[aeiouy][yuoiea]> or C<tr(+\-*/)/ABCD/>.
+I<SEARCHLIST> is delimited by bracketing quotes, the I<REPLACEMENTLIST>
+must have its own pair of quotes, which may or may not be bracketing
+quotes; for example, C<tr[aeiouy][yuoiea]> or C<tr(+\-*/)/ABCD/>.
Characters may be literals or any of the escape sequences accepted in
double-quoted strings. But there is no interpolation, so C<"$"> and
Note that C<tr> does B<not> do regular expression character classes such as
C<\d> or C<\pL>. The C<tr> operator is not equivalent to the C<L<tr(1)>>
-utility. If you want to map strings between lower/upper cases, see
-L<perlfunc/lc> and L<perlfunc/uc>, and in general consider using the C<s>
-operator if you need regular expressions. The C<\U>, C<\u>, C<\L>, and
-C<\l> string-interpolation escapes on the right side of a substitution
-operator will perform correct case-mappings, but C<tr[a-z][A-Z]> will not
-(except sometimes on legacy 7-bit data).
+utility. C<tr[a-z][A-Z]> will uppercase the 26 letters "a" through "z",
+but for case changing not confined to ASCII, use
+L<C<lc>|perlfunc/lc>, L<C<uc>|perlfunc/uc>,
+L<C<lcfirst>|perlfunc/lcfirst>, L<C<ucfirst>|perlfunc/ucfirst>
+(all documented in L<perlfunc>), or the
+L<substitution operator C<sE<sol>I<PATTERN>E<sol>I<REPLACEMENT>E<sol>>|/sE<sol>PATTERNE<sol>REPLACEMENTE<sol>msixpodualngcer>
+(with C<\U>, C<\u>, C<\L>, and C<\l> string-interpolation escapes in the
+I<REPLACEMENT> portion).
Most ranges are unportable between character sets, but certain ones
signal Perl to do special handling to make them portable. There are two
But, even for portable ranges, it is not generally obvious what is
included without having to look things up. A sound principle is to use
only ranges that begin from and end at either ASCII alphabetics of equal
-case (C<b-e>, C<b-E>), or digits (C<1-4>). Anything else is unclear
+case (C<b-e>, C<B-E>), or digits (C<1-4>). Anything else is unclear
(and unportable unless C<\N{...}> is used). If in doubt, spell out the
character sets in full.
reading or writing. Unix does the same thing on ttys in canonical
mode. C<\015\012> is commonly referred to as CRLF.
-To trim trailing newlines from text lines use C<chomp()>. With default
-settings that function looks for a trailing C<\n> character and thus
-trims in a portable way.
+To trim trailing newlines from text lines use
+L<C<chomp>|perlfunc/chomp VARIABLE>. With default settings that function
+looks for a trailing C<\n> character and thus trims in a portable way.
When dealing with binary files (or text files in binary mode) be sure
-to explicitly set $/ to the appropriate value for your file format
-before using C<chomp()>.
-
-Because of the "text" mode translation, DOSish perls have limitations
-in using C<seek> and C<tell> on a file accessed in "text" mode.
-Stick to C<seek>-ing to locations you got from C<tell> (and no
-others), and you are usually free to use C<seek> and C<tell> even
-in "text" mode. Using C<seek> or C<tell> or other file operations
-may be non-portable. If you use C<binmode> on a file, however, you
-can usually C<seek> and C<tell> with arbitrary values safely.
+to explicitly set L<C<$E<sol>>|perlvar/$E<sol>> to the appropriate value for
+your file format before using L<C<chomp>|perlfunc/chomp VARIABLE>.
+
+Because of the "text" mode translation, DOSish perls have limitations in
+using L<C<seek>|perlfunc/seek FILEHANDLE,POSITION,WHENCE> and
+L<C<tell>|perlfunc/tell FILEHANDLE> on a file accessed in "text" mode.
+Stick to L<C<seek>|perlfunc/seek FILEHANDLE,POSITION,WHENCE>-ing to
+locations you got from L<C<tell>|perlfunc/tell FILEHANDLE> (and no
+others), and you are usually free to use
+L<C<seek>|perlfunc/seek FILEHANDLE,POSITION,WHENCE> and
+L<C<tell>|perlfunc/tell FILEHANDLE> even in "text" mode. Using
+L<C<seek>|perlfunc/seek FILEHANDLE,POSITION,WHENCE> or
+L<C<tell>|perlfunc/tell FILEHANDLE> or other file operations may be
+non-portable. If you use L<C<binmode>|perlfunc/binmode FILEHANDLE> on a
+file, however, you can usually
+L<C<seek>|perlfunc/seek FILEHANDLE,POSITION,WHENCE> and
+L<C<tell>|perlfunc/tell FILEHANDLE> with arbitrary values safely.
A common misconception in socket programming is that S<C<\n eq \012>>
everywhere. When using protocols such as common Internet protocols,
C<\012> and C<\015> are called for specifically, and the values of
the logical C<\n> and C<\r> (carriage return) are not reliable.
- print SOCKET "Hi there, client!\r\n"; # WRONG
- print SOCKET "Hi there, client!\015\012"; # RIGHT
+ print $socket "Hi there, client!\r\n"; # WRONG
+ print $socket "Hi there, client!\015\012"; # RIGHT
However, using C<\015\012> (or C<\cM\cJ>, or C<\x0D\x0A>) can be tedious
and unsightly, as well as confusing to those maintaining the code. As
-such, the C<Socket> module supplies the Right Thing for those who want it.
+such, the L<C<Socket>|Socket> module supplies the Right Thing for those
+who want it.
use Socket qw(:DEFAULT :crlf);
- print SOCKET "Hi there, client!$CRLF" # RIGHT
+ print $socket "Hi there, client!$CRLF" # RIGHT
When reading from a socket, remember that the default input record
-separator C<$/> is C<\n>, but robust socket code will recognize as
-either C<\012> or C<\015\012> as end of line:
+separator L<C<$E<sol>>|perlvar/$E<sol>> is C<\n>, but robust socket code
+will recognize as either C<\012> or C<\015\012> as end of line:
- while (<SOCKET>) { # NOT ADVISABLE!
+ while (<$socket>) { # NOT ADVISABLE!
# ...
}
use Socket qw(:DEFAULT :crlf);
local($/) = LF; # not needed if $/ is already \012
- while (<SOCKET>) {
+ while (<$socket>) {
s/$CR?$LF/\n/; # not sure if socket uses LF or CRLF, OK
# s/\015?\012/\n/; # same thing
}
0x78563412 (2018915346 in decimal). Alpha and MIPS can be either:
Digital/Compaq used/uses them in little-endian mode; SGI/Cray uses
them in big-endian mode. To avoid this problem in network (socket)
-connections use the C<pack> and C<unpack> formats C<n> and C<N>, the
+connections use the L<C<pack>|perlfunc/pack TEMPLATE,LIST> and
+L<C<unpack>|perlfunc/unpack TEMPLATE,EXPR> formats C<n> and C<N>, the
"network" orders. These are guaranteed to be portable.
As of Perl 5.10.0, you can also use the C<E<gt>> and C<E<lt>> modifiers
One can circumnavigate both these problems in two ways. Either
transfer and store numbers always in text format, instead of raw
-binary, or else consider using modules like C<Data::Dumper> and
-C<Storable>
-(included as of Perl 5.8). Keeping all data as text significantly
-simplifies matters.
+binary, or else consider using modules like
+L<C<Data::Dumper>|Data::Dumper> and L<C<Storable>|Storable> (included as
+of Perl 5.8). Keeping all data as text significantly simplifies matters.
=head2 Files and Filesystems
S<Mac OS> 9 and earlier used C<:> as a path separator instead of C</>.
-The filesystem may support neither hard links (C<link>) nor
-symbolic links (C<symlink>, C<readlink>, C<lstat>).
+The filesystem may support neither hard links
+(L<C<link>|perlfunc/link OLDFILE,NEWFILE>) nor symbolic links
+(L<C<symlink>|perlfunc/symlink OLDFILE,NEWFILE>,
+L<C<readlink>|perlfunc/readlink EXPR>,
+L<C<lstat>|perlfunc/lstat FILEHANDLE>).
The filesystem may support neither access timestamp nor change
timestamp (meaning that about the only portable timestamp is the
modification timestamp), or one second granularity of any timestamps
(e.g. the FAT filesystem limits the time granularity to two seconds).
-The "inode change timestamp" (the C<-C> filetest) may really be the
-"creation timestamp" (which it is not in Unix).
+The "inode change timestamp" (the L<C<-C>|perlfunc/-X FILEHANDLE>
+filetest) may really be the "creation timestamp" (which it is not in
+Unix).
VOS perl can emulate Unix filenames with C</> as path separator. The
native pathname characters greater-than, less-than, number-sign, and
Don't assume Unix filesystem access semantics: that read, write,
and execute are all the permissions there are, and even if they exist,
-that their semantics (for example what do C<"r">, C<"w">, and C<"x"> mean on
+that their semantics (for example what do C<r>, C<w>, and C<x> mean on
a directory) are the Unix ones. The various Unix/POSIX compatibility
-layers usually try to make interfaces like C<chmod()> work, but sometimes
-there simply is no good mapping.
+layers usually try to make interfaces like L<C<chmod>|perlfunc/chmod LIST>
+work, but sometimes there simply is no good mapping.
-The C<File::Spec> modules provide methods to manipulate path
+The L<C<File::Spec>|File::Spec> modules provide methods to manipulate path
specifications and return the results in native format for each
platform. This is often unnecessary as Unix-style paths are
understood by Perl on every supported platform, but if you need to
produce native paths for a native utility that does not understand
Unix syntax, or if you are operating on paths or path components
-in unknown (and thus possibly native) syntax, C<File::Spec> is
-your friend. Here are two brief examples:
+in unknown (and thus possibly native) syntax, L<C<File::Spec>|File::Spec>
+is your friend. Here are two brief examples:
use File::Spec::Functions;
chdir(updir()); # go up one directory
This is especially noticeable in scripts like Makefiles and test suites,
which often assume C</> as a path separator for subdirectories.
-Also of use is C<File::Basename> from the standard distribution, which
-splits a pathname into pieces (base filename, full path to directory,
-and file suffix).
+Also of use is L<C<File::Basename>|File::Basename> from the standard
+distribution, which splits a pathname into pieces (base filename, full
+path to directory, and file suffix).
Even when on a single platform (if you can call Unix a single platform),
remember not to count on the existence or the contents of particular
keep them to the 8.3 convention, for maximum portability, onerous a
burden though this may appear.
-Likewise, when using the C<AutoSplit> module, try to keep your functions to
-8.3 naming and case-insensitive conventions; or, at the least,
-make it so the resulting files have a unique (case-insensitively)
+Likewise, when using the L<C<AutoSplit>|AutoSplit> module, try to keep
+your functions to 8.3 naming and case-insensitive conventions; or, at the
+least, make it so the resulting files have a unique (case-insensitively)
first 8 characters.
Whitespace in filenames is tolerated on most systems, but not all,
filenames.
Don't assume C<< > >> won't be the first character of a filename.
-Always use C<< < >> explicitly to open a file for reading, or even
-better, use the three-arg version of C<open>, unless you want the user to
-be able to specify a pipe open.
+Always use the three-arg version of
+L<C<open>|perlfunc/open FILEHANDLE,EXPR>:
open my $fh, '<', $existing_file) or die $!;
-If filenames might use strange characters, it is safest to open it
-with C<sysopen> instead of C<open>. C<open> is magic and can
-translate characters like C<< > >>, C<< < >>, and C<|>, which may
-be the wrong thing to do. (Sometimes, though, it's the right thing.)
-Three-arg open can also help protect against this translation in cases
-where it is undesirable.
+Two-arg L<C<open>|perlfunc/open FILEHANDLE,EXPR> is magic and can
+translate characters like C<< > >>, C<< < >>, and C<|> in filenames,
+which is usually the wrong thing to do.
+L<C<sysopen>|perlfunc/sysopen FILEHANDLE,FILENAME,MODE> and three-arg
+L<C<open>|perlfunc/open FILEHANDLE,EXPR> don't have this problem.
Don't use C<:> as a part of a filename since many systems use that for
their own semantics (Mac OS Classic for separating pathname components,
0 1 2 3 4 5 6 7 8 9
. _ -
-and the C<"-"> shouldn't be the first character. If you want to be
+and C<-> shouldn't be the first character. If you want to be
hypercorrect, stay case-insensitive and within the 8.3 naming
convention (all the files and directories have to be unique within one
directory if their names are lowercased and truncated to eight
Some platforms can't delete or rename files held open by the system,
this limitation may also apply to changing filesystem metainformation
-like file permissions or owners. Remember to C<close> files when you
-are done with them. Don't C<unlink> or C<rename> an open file. Don't
-C<tie> or C<open> a file already tied or opened; C<untie> or C<close>
-it first.
+like file permissions or owners. Remember to
+L<C<close>|perlfunc/close FILEHANDLE> files when you are done with them.
+Don't L<C<unlink>|perlfunc/unlink LIST> or
+L<C<rename>|perlfunc/rename OLDNAME,NEWNAME> an open file. Don't
+L<C<tie>|perlfunc/tie VARIABLE,CLASSNAME,LIST> or
+L<C<open>|perlfunc/open FILEHANDLE,EXPR> a file already tied or opened;
+L<C<untie>|perlfunc/untie VARIABLE> or
+L<C<close>|perlfunc/close FILEHANDLE> it first.
Don't open the same file more than once at a time for writing, as some
operating systems put mandatory locks on such files.
filesystems (AFS, DFS) the permission to add/delete directory entries
is a completely separate permission.
-Don't assume that a single C<unlink> completely gets rid of the file:
-some filesystems (most notably the ones in VMS) have versioned
-filesystems, and C<unlink()> removes only the most recent one (it doesn't
-remove all the versions because by default the native tools on those
-platforms remove just the most recent version, too). The portable
-idiom to remove all the versions of a file is
+Don't assume that a single L<C<unlink>|perlfunc/unlink LIST> completely
+gets rid of the file: some filesystems (most notably the ones in VMS) have
+versioned filesystems, and L<C<unlink>|perlfunc/unlink LIST> removes only
+the most recent one (it doesn't remove all the versions because by default
+the native tools on those platforms remove just the most recent version,
+too). The portable idiom to remove all the versions of a file is
1 while unlink "file";
This will terminate if the file is undeleteable for some reason
(protected, not there, and so on).
-Don't count on a specific environment variable existing in C<%ENV>.
-Don't count on C<%ENV> entries being case-sensitive, or even
-case-preserving. Don't try to clear C<%ENV> by saying C<%ENV = ();>, or,
-if you really have to, make it conditional on C<$^O ne 'VMS'> since in
-VMS the C<%ENV> table is much more than a per-process key-value string
-table.
-
-On VMS, some entries in the C<%ENV> hash are dynamically created when
-their key is used on a read if they did not previously exist. The
-values for C<$ENV{HOME}>, C<$ENV{TERM}>, C<$ENV{PATH}>, and C<$ENV{USER}>,
-are known to be dynamically generated. The specific names that are
-dynamically generated may vary with the version of the C library on VMS,
-and more may exist than are documented.
-
-On VMS by default, changes to the %ENV hash persist after perl exits.
-Subsequent invocations of perl in the same process can inadvertently
-inherit environment settings that were meant to be temporary.
-
-Don't count on signals or C<%SIG> for anything.
-
-Don't count on filename globbing. Use C<opendir>, C<readdir>, and
-C<closedir> instead.
+Don't count on a specific environment variable existing in
+L<C<%ENV>|perlvar/%ENV>. Don't count on L<C<%ENV>|perlvar/%ENV> entries
+being case-sensitive, or even case-preserving. Don't try to clear
+L<C<%ENV>|perlvar/%ENV> by saying C<%ENV = ();>, or, if you really have
+to, make it conditional on C<$^O ne 'VMS'> since in VMS the
+L<C<%ENV>|perlvar/%ENV> table is much more than a per-process key-value
+string table.
+
+On VMS, some entries in the L<C<%ENV>|perlvar/%ENV> hash are dynamically
+created when their key is used on a read if they did not previously
+exist. The values for C<$ENV{HOME}>, C<$ENV{TERM}>, C<$ENV{PATH}>, and
+C<$ENV{USER}>, are known to be dynamically generated. The specific names
+that are dynamically generated may vary with the version of the C library
+on VMS, and more may exist than are documented.
+
+On VMS by default, changes to the L<C<%ENV>|perlvar/%ENV> hash persist
+after perl exits. Subsequent invocations of perl in the same process can
+inadvertently inherit environment settings that were meant to be
+temporary.
+
+Don't count on signals or L<C<%SIG>|perlvar/%SIG> for anything.
+
+Don't count on filename globbing. Use
+L<C<opendir>|perlfunc/opendir DIRHANDLE,EXPR>,
+L<C<readdir>|perlfunc/readdir DIRHANDLE>, and
+L<C<closedir>|perlfunc/closedir DIRHANDLE> instead.
Don't count on per-program environment variables, or per-program current
directories.
-Don't count on specific values of C<$!>, neither numeric nor
+Don't count on specific values of L<C<$!>|perlvar/$!>, neither numeric nor
especially the string values. Users may switch their locales causing
error messages to be translated into their languages. If you can
trust a POSIXish environment, you can portably use the symbols defined
-by the C<Errno> module, like C<ENOENT>. And don't trust on the values of C<$!>
-at all except immediately after a failed system call.
+by the L<C<Errno>|Errno> module, like C<ENOENT>. And don't trust on the
+values of L<C<$!>|perlvar/$!> at all except immediately after a failed
+system call.
=head2 Command names versus file pathnames
Don't assume that the name used to invoke a command or program with
-C<system> or C<exec> can also be used to test for the existence of the
-file that holds the executable code for that command or program.
+L<C<system>|perlfunc/system LIST> or L<C<exec>|perlfunc/exec LIST> can
+also be used to test for the existence of the file that holds the
+executable code for that command or program.
First, many systems have "internal" commands that are built-in to the
shell or OS and while these commands can be invoked, there is no
corresponding file. Second, some operating systems (e.g., Cygwin,
DJGPP, OS/2, and VOS) have required suffixes for executable files;
these suffixes are generally permitted on the command name but are not
-required. Thus, a command like F<"perl"> might exist in a file named
-F<"perl">, F<"perl.exe">, or F<"perl.pm">, depending on the operating system.
-The variable C<"_exe"> in the C<Config> module holds the executable suffix,
-if any. Third, the VMS port carefully sets up C<$^X> and
-C<$Config{perlpath}> so that no further processing is required. This is
-just as well, because the matching regular expression used below would
-then have to deal with a possible trailing version number in the VMS
-file name.
-
-To convert C<$^X> to a file pathname, taking account of the requirements
-of the various operating system possibilities, say:
+required. Thus, a command like C<perl> might exist in a file named
+F<perl>, F<perl.exe>, or F<perl.pm>, depending on the operating system.
+The variable L<C<$Config{_exe}>|Config/C<_exe>> in the
+L<C<Config>|Config> module holds the executable suffix, if any. Third,
+the VMS port carefully sets up L<C<$^X>|perlvar/$^X> and
+L<C<$Config{perlpath}>|Config/C<perlpath>> so that no further processing
+is required. This is just as well, because the matching regular
+expression used below would then have to deal with a possible trailing
+version number in the VMS file name.
+
+To convert L<C<$^X>|perlvar/$^X> to a file pathname, taking account of
+the requirements of the various operating system possibilities, say:
use Config;
my $thisperl = $^X;
- if ($^O ne 'VMS')
- {$thisperl .= $Config{_exe} unless $thisperl =~ m/$Config{_exe}$/i;}
+ if ($^O ne 'VMS') {
+ $thisperl .= $Config{_exe}
+ unless $thisperl =~ m/\Q$Config{_exe}\E$/i;
+ }
-To convert C<$Config{perlpath}> to a file pathname, say:
+To convert L<C<$Config{perlpath}>|Config/C<perlpath>> to a file pathname, say:
use Config;
my $thisperl = $Config{perlpath};
- if ($^O ne 'VMS')
- {$thisperl .= $Config{_exe} unless $thisperl =~ m/$Config{_exe}$/i;}
+ if ($^O ne 'VMS') {
+ $thisperl .= $Config{_exe}
+ unless $thisperl =~ m/\Q$Config{_exe}\E$/i;
+ }
=head2 Networking
Don't assume a particular network device name.
-Don't assume a particular set of C<ioctl()>s will work.
+Don't assume a particular set of
+L<C<ioctl>|perlfunc/ioctl FILEHANDLE,FUNCTION,SCALAR>s will work.
Don't assume that you can ping hosts and get replies.
Don't assume that any particular port (service) will respond.
-Don't assume that C<Sys::Hostname> (or any other API or command) returns
-either a fully qualified hostname or a non-qualified hostname: it all
-depends on how the system had been configured. Also remember that for
-things such as DHCP and NAT, the hostname you get back might not be
-very useful.
+Don't assume that L<C<Sys::Hostname>|Sys::Hostname> (or any other API or
+command) returns either a fully qualified hostname or a non-qualified
+hostname: it all depends on how the system had been configured. Also
+remember that for things such as DHCP and NAT, the hostname you get back
+might not be very useful.
All the above I<don't>s may look daunting, and they are, but the key
is to degrade gracefully if one cannot reach the particular network
=head2 Interprocess Communication (IPC)
In general, don't directly access the system in code meant to be
-portable. That means, no C<system>, C<exec>, C<fork>, C<pipe>,
-C<``>, C<qx//>, C<open> with a C<|>, nor any of the other things
-that makes being a Perl hacker worth being.
+portable. That means, no L<C<system>|perlfunc/system LIST>,
+L<C<exec>|perlfunc/exec LIST>, L<C<fork>|perlfunc/fork>,
+L<C<pipe>|perlfunc/pipe READHANDLE,WRITEHANDLE>,
+L<C<``> or C<qxE<sol>E<sol>>|perlop/C<qxE<sol>I<STRING>E<sol>>>,
+L<C<open>|perlfunc/open FILEHANDLE,EXPR> with a C<|>, nor any of the other
+things that makes being a Perl hacker worth being.
Commands that launch external processes are generally supported on
most platforms (though many of them do not support any type of
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
-I<netstat -a>, you probably don't expect it to run on both Unix and CP/M.)
+on them to produce consistent results. (Then again, if you're calling
+C<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(my $mail, '|-', '/usr/lib/sendmail -t')
or die "cannot fork sendmail: $!";
This is fine for systems programming when sendmail is known to be
available. But it is not fine for many non-Unix systems, and even
some Unix systems that may not have sendmail installed. If a portable
solution is needed, see the various distributions on CPAN that deal
-with it. C<Mail::Mailer> and C<Mail::Send> in the C<MailTools> distribution are
-commonly used, and provide several mailing methods, including C<mail>,
-C<sendmail>, and direct SMTP (via C<Net::SMTP>) if a mail transfer agent is
-not available. C<Mail::Sendmail> is a standalone module that provides
+with it. L<C<Mail::Mailer>|Mail::Mailer> and L<C<Mail::Send>|Mail::Send>
+in the C<MailTools> distribution are commonly used, and provide several
+mailing methods, including C<mail>, C<sendmail>, and direct SMTP (via
+L<C<Net::SMTP>|Net::SMTP>) if a mail transfer agent is not available.
+L<C<Mail::Sendmail>|Mail::Sendmail> is a standalone module that provides
simple, platform-independent mailing.
The Unix System V IPC (C<msg*(), sem*(), shm*()>) is not available
both forms just pack the four bytes into network order. That this
would be equal to the C language C<in_addr> struct (which is what the
socket code internally uses) is not guaranteed. To be portable use
-the routines of the C<Socket> extension, such as C<inet_aton()>,
-C<inet_ntoa()>, and C<sockaddr_in()>.
+the routines of the L<C<Socket>|Socket> module, such as
+L<C<inet_aton>|Socket/$ip_address = inet_aton $string>,
+L<C<inet_ntoa>|Socket/$string = inet_ntoa $ip_address>, and
+L<C<sockaddr_in>|Socket/$sockaddr = sockaddr_in $port, $ip_address>.
The rule of thumb for portable code is: Do it all in portable Perl, or
use a module (that may internally implement it with platform-specific
=head2 Standard Modules
In general, the standard modules work across platforms. Notable
-exceptions are the C<CPAN> module (which currently makes connections to external
-programs that may not be available), platform-specific modules (like
-C<ExtUtils::MM_VMS>), and DBM modules.
+exceptions are the L<C<CPAN>|CPAN> module (which currently makes
+connections to external programs that may not be available),
+platform-specific modules (like L<C<ExtUtils::MM_VMS>|ExtUtils::MM_VMS>),
+and DBM modules.
There is no one DBM module available on all platforms.
-C<SDBM_File> and the others are generally available on all Unix and DOSish
-ports, but not in MacPerl, where only C<NDBM_File> and C<DB_File> are
-available.
+L<C<SDBM_File>|SDBM_File> and the others are generally available on all
+Unix and DOSish ports, but not in MacPerl, where only
+L<C<NDBM_File>|NDBM_File> and L<C<DB_File>|DB_File> are available.
The good news is that at least some DBM module should be available, and
-C<AnyDBM_File> will use whichever module it can find. Of course, then
-the code needs to be fairly strict, dropping to the greatest common
-factor (e.g., not exceeding 1K for each record), so that it will
+L<C<AnyDBM_File>|AnyDBM_File> will use whichever module it can find. Of
+course, then the code needs to be fairly strict, dropping to the greatest
+common factor (e.g., not exceeding 1K for each record), so that it will
work with any DBM module. See L<AnyDBM_File> for more details.
=head2 Time and Date
Please do use the ISO 8601 instead of making us guess what
date 02/03/04 might be. ISO 8601 even sorts nicely as-is.
A text representation (like "1987-12-18") can be easily converted
-into an OS-specific value using a module like C<Date::Parse>.
-An array of values, such as those returned by C<localtime>, can be
-converted to an OS-specific representation using C<Time::Local>.
+into an OS-specific value using a module like
+L<C<Time::Piece>|Time::Piece> (see L<Time::Piece/Date Parsing>) or
+L<C<Date::Parse>|Date::Parse>. An array of values, such as those
+returned by L<C<localtime>|perlfunc/localtime EXPR>, can be converted to an OS-specific
+representation using L<C<Time::Local>|Time::Local>.
When calculating specific times, such as for tests in time or date modules,
it may be appropriate to calculate an offset for the epoch.
- require Time::Local;
- my $offset = Time::Local::timegm(0, 0, 0, 1, 0, 70);
+ use Time::Local qw(timegm);
+ my $offset = timegm(0, 0, 0, 1, 0, 70);
The value for C<$offset> in Unix will be C<0>, but in Mac OS Classic
will be some large number. C<$offset> can then be added to a Unix time
Assume very little about character sets.
-Assume nothing about numerical values (C<ord>, C<chr>) of characters.
+Assume nothing about numerical values (L<C<ord>|perlfunc/ord EXPR>,
+L<C<chr>|perlfunc/chr NUMBER>) of characters.
Do not use explicit code point ranges (like C<\xHH-\xHH)>. However,
starting in Perl v5.22, regular expression pattern bracketed character
class ranges specified like C<qr/[\N{U+HH}-\N{U+HH}]/> are portable,
-and starting in Perl v5.24, the same ranges are portable in C<tr///>.
+and starting in Perl v5.24, the same ranges are portable in
+L<C<trE<sol>E<sol>E<sol>>|perlop/C<trE<sol>I<SEARCHLIST>E<sol>I<REPLACEMENTLIST>E<sol>cdsr>>.
You can portably use symbolic character classes like C<[:print:]>.
Do not assume that the alphabetic characters are encoded contiguously
(in the numeric sense). There may be gaps. Special coding in Perl,
however, guarantees that all subsets of C<qr/[A-Z]/>, C<qr/[a-z]/>, and
-C<qr/[0-9]/> behave as expected. C<tr///> behaves the same for these
-ranges. In patterns, any ranges specified with end points using the
-C<\N{...}> notations ensures character set portability, but it is a bug
-in Perl v5.22, that this isn't true of C<tr///>, fixed in v5.24.
+C<qr/[0-9]/> behave as expected.
+L<C<trE<sol>E<sol>E<sol>>|perlop/C<trE<sol>I<SEARCHLIST>E<sol>I<REPLACEMENTLIST>E<sol>cdsr>>
+behaves the same for these ranges. In patterns, any ranges specified with
+end points using the C<\N{...}> notations ensures character set
+portability, but it is a bug in Perl v5.22 that this isn't true of
+L<C<trE<sol>E<sol>E<sol>>|perlop/C<trE<sol>I<SEARCHLIST>E<sol>I<REPLACEMENTLIST>E<sol>cdsr>>,
+fixed in v5.24.
Do not assume anything about the ordering of the characters.
The lowercase letters may come before or after the uppercase letters;
If you really want to be international, you should consider Unicode.
See L<perluniintro> and L<perlunicode> for more information.
-If you want to use non-ASCII bytes (outside the bytes 0x00..0x7f) in
-the "source code" of your code, to be portable you have to be explicit
-about what bytes they are. Someone might for example be using your
-code under a UTF-8 locale, in which case random native bytes might be
-illegal ("Malformed UTF-8 ...") This means that for example embedding
-ISO 8859-1 bytes beyond 0x7f into your strings might cause trouble
-later. If the bytes are native 8-bit bytes, you can use the C<bytes>
-pragma. If the bytes are in a string (regular expressions being
-curious strings), you can often also use the C<\xHH> or more portably,
-the C<\N{U+HH}> notations instead
-of embedding the bytes as-is. If you want to write your code in UTF-8,
-you can use L<utf8>.
+By default Perl assumes your source code is written in an 8-bit ASCII
+superset. To embed Unicode characters in your strings and regexes, you can
+use the L<C<\x{HH}> or (more portably) C<\N{U+HH}>
+notations|perlop/Quote and Quote-like Operators>. You can also use the
+L<C<utf8>|utf8> pragma and write your code in UTF-8, which lets you use
+Unicode characters directly (not just in quoted constructs but also in
+identifiers).
=head2 System Resources
Just try the operation.)
Don't assume the Unix user and group semantics: especially, don't
-expect C<< $< >> and C<< $> >> (or C<$(> and C<$)>) to work
-for switching identities (or memberships).
+expect L<C<< $< >>|perlvar/$E<lt>> and L<C<< $> >>|perlvar/$E<gt>> (or
+L<C<$(>|perlvar/$(> and L<C<$)>|perlvar/$)>) to work for switching
+identities (or memberships).
-Don't assume set-uid and set-gid semantics. (And even if you do,
+Don't assume set-uid and set-gid semantics. (And even if you do,
think twice: set-uid and set-gid are a known can of security worms.)
=head2 Style
For those times when it is necessary to have platform-specific code,
consider keeping the platform-specific code in one place, making porting
-to other platforms easier. Use the C<Config> module and the special
-variable C<$^O> to differentiate platforms, as described in
-L</"PLATFORMS">.
+to other platforms easier. Use the L<C<Config>|Config> module and the
+special variable L<C<$^O>|perlvar/$^O> to differentiate platforms, as
+described in L</"PLATFORMS">.
Beware of the "else syndrome":
programs to aid in the testing, or when (as noted above) the tests
assume certain things about the filesystem and paths. Be careful not
to depend on a specific output style for errors, such as when checking
-C<$!> after a failed system call. Using C<$!> for anything else than
-displaying it as output is doubtful (though see the C<Errno> module for
-testing reasonably portably for error value). Some platforms expect
-a certain output format, and Perl on those platforms may have been
-adjusted accordingly. Most specifically, don't anchor a regex when
-testing an error value.
+L<C<$!>|perlvar/$!> after a failed system call. Using
+L<C<$!>|perlvar/$!> for anything else than displaying it as output is
+doubtful (though see the L<C<Errno>|Errno> module for testing reasonably
+portably for error value). Some platforms expect a certain output format,
+and Perl on those platforms may have been adjusted accordingly. Most
+specifically, don't anchor a regex when testing an error value.
=head1 CPAN Testers
=head1 PLATFORMS
-Perl is built with a C<$^O> variable that indicates the operating
-system it was built on. This was implemented
+Perl is built with a L<C<$^O>|perlvar/$^O> variable that indicates the
+operating system it was built on. This was implemented
to help speed up code that would otherwise have to C<use Config>
-and use the value of C<$Config{osname}>. Of course, to get more
-detailed information about the system, looking into C<%Config> is
-certainly recommended.
+and use the value of L<C<$Config{osname}>|Config/C<osname>>. Of course,
+to get more detailed information about the system, looking into
+L<C<%Config>|Config/DESCRIPTION> is certainly recommended.
-C<%Config> cannot always be trusted, however, because it was built
-at compile time. If perl was built in one place, then transferred
-elsewhere, some values may be wrong. The values may even have been
-edited after the fact.
+L<C<%Config>|Config/DESCRIPTION> cannot always be trusted, however,
+because it was built at compile time. If perl was built in one place,
+then transferred elsewhere, some values may be wrong. The values may
+even have been edited after the fact.
=head2 Unix
Perl works on a bewildering variety of Unix and Unix-like platforms (see
e.g. most of the files in the F<hints/> directory in the source code kit).
-On most of these systems, the value of C<$^O> (hence C<$Config{'osname'}>,
-too) is determined either by lowercasing and stripping punctuation from the
-first field of the string returned by typing C<uname -a> (or a similar command)
-at the shell prompt or by testing the file system for the presence of
-uniquely named files such as a kernel or header file. Here, for example,
-are a few of the more popular Unix flavors:
-
- uname $^O $Config{'archname'}
+On most of these systems, the value of L<C<$^O>|perlvar/$^O> (hence
+L<C<$Config{osname}>|Config/C<osname>>, too) is determined either by
+lowercasing and stripping punctuation from the first field of the string
+returned by typing C<uname -a> (or a similar command) at the shell prompt
+or by testing the file system for the presence of uniquely named files
+such as a kernel or header file. Here, for example, are a few of the
+more popular Unix flavors:
+
+ uname $^O $Config{archname}
--------------------------------------------
AIX aix aix
BSD/OS bsdos i386-bsdos
SunOS solaris i86pc-solaris
SunOS4 sunos sun4-sunos
-Because the value of C<$Config{archname}> may depend on the
-hardware architecture, it can vary more than the value of C<$^O>.
+Because the value of L<C<$Config{archname}>|Config/C<archname>> may
+depend on the hardware architecture, it can vary more than the value of
+L<C<$^O>|perlvar/$^O>.
=head2 DOS and Derivatives
The DOS FAT filesystem can accommodate only "8.3" style filenames. Under
the "case-insensitive, but case-preserving" HPFS (OS/2) and NTFS (NT)
filesystems you may have to be careful about case returned with functions
-like C<readdir> or used with functions like C<open> or C<opendir>.
+like L<C<readdir>|perlfunc/readdir DIRHANDLE> or used with functions like
+L<C<open>|perlfunc/open FILEHANDLE,EXPR> or
+L<C<opendir>|perlfunc/opendir DIRHANDLE,EXPR>.
-DOS also treats several filenames as special, such as AUX, PRN,
-NUL, CON, COM1, LPT1, LPT2, etc. Unfortunately, sometimes these
-filenames won't even work if you include an explicit directory
-prefix. It is best to avoid such filenames, if you want your code
-to be portable to DOS and its derivatives. It's hard to know what
-these all are, unfortunately.
+DOS also treats several filenames as special, such as F<AUX>, F<PRN>,
+F<NUL>, F<CON>, F<COM1>, F<LPT1>, F<LPT2>, etc. Unfortunately, sometimes
+these filenames won't even work if you include an explicit directory
+prefix. It is best to avoid such filenames, if you want your code to be
+portable to DOS and its derivatives. It's hard to know what these all
+are, unfortunately.
Users of these operating systems may also wish to make use of
-scripts such as I<pl2bat.bat> or I<pl2cmd> to
-put wrappers around your scripts.
-
-Newline (C<\n>) is translated as C<\015\012> by STDIO when reading from
-and writing to files (see L</"Newlines">). C<binmode(FILEHANDLE)>
-will keep C<\n> translated as C<\012> for that filehandle. Since it is a
-no-op on other systems, C<binmode> should be used for cross-platform code
-that deals with binary data. That's assuming you realize in advance
-that your data is in binary. General-purpose programs should
-often assume nothing about their data.
-
-The C<$^O> variable and the C<$Config{archname}> values for various
-DOSish perls are as follows:
-
- OS $^O $Config{archname} ID Version
- --------------------------------------------------------
- MS-DOS dos ?
- PC-DOS dos ?
- OS/2 os2 ?
- Windows 3.1 ? ? 0 3 01
- Windows 95 MSWin32 MSWin32-x86 1 4 00
- Windows 98 MSWin32 MSWin32-x86 1 4 10
- Windows ME MSWin32 MSWin32-x86 1 ?
- Windows NT MSWin32 MSWin32-x86 2 4 xx
- Windows NT MSWin32 MSWin32-ALPHA 2 4 xx
- Windows NT MSWin32 MSWin32-ppc 2 4 xx
- Windows 2000 MSWin32 MSWin32-x86 2 5 00
- Windows XP MSWin32 MSWin32-x86 2 5 01
- Windows 2003 MSWin32 MSWin32-x86 2 5 02
- Windows Vista MSWin32 MSWin32-x86 2 6 00
- Windows 7 MSWin32 MSWin32-x86 2 6 01
- 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
- Cygwin cygwin cygwin
+scripts such as F<pl2bat.bat> to put wrappers around your scripts.
+
+Newline (C<\n>) is translated as C<\015\012> by the I/O system when
+reading from and writing to files (see L</"Newlines">).
+C<binmode($filehandle)> will keep C<\n> translated as C<\012> for that
+filehandle.
+L<C<binmode>|perlfunc/binmode FILEHANDLE> should always be used for code
+that deals with binary data. That's assuming you realize in advance that
+your data is in binary. General-purpose programs should often assume
+nothing about their data.
+
+The L<C<$^O>|perlvar/$^O> variable and the
+L<C<$Config{archname}>|Config/C<archname>> values for various DOSish
+perls are as follows:
+
+ OS $^O $Config{archname} ID Version
+ ---------------------------------------------------------
+ MS-DOS dos ?
+ PC-DOS dos ?
+ OS/2 os2 ?
+ Windows 3.1 ? ? 0 3 01
+ Windows 95 MSWin32 MSWin32-x86 1 4 00
+ Windows 98 MSWin32 MSWin32-x86 1 4 10
+ Windows ME MSWin32 MSWin32-x86 1 ?
+ Windows NT MSWin32 MSWin32-x86 2 4 xx
+ Windows NT MSWin32 MSWin32-ALPHA 2 4 xx
+ Windows NT MSWin32 MSWin32-ppc 2 4 xx
+ Windows 2000 MSWin32 MSWin32-x86 2 5 00
+ Windows XP MSWin32 MSWin32-x86 2 5 01
+ Windows 2003 MSWin32 MSWin32-x86 2 5 02
+ Windows Vista MSWin32 MSWin32-x86 2 6 00
+ Windows 7 MSWin32 MSWin32-x86 2 6 01
+ 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
+ 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
-C<Win32::GetOSVersion()>. For example:
+L<C<Win32::GetOSVersion()>|Win32/Win32::GetOSVersion()>. For example:
if ($^O eq 'MSWin32') {
my @os_version_info = Win32::GetOSVersion();
print +('3.1','95','NT')[$os_version_info[4]],"\n";
}
-There are also C<Win32::IsWinNT()> and C<Win32::IsWin95()>; try C<perldoc Win32>,
-and as of libwin32 0.19 (not part of the core Perl distribution)
-C<Win32::GetOSName()>. The very portable C<POSIX::uname()> will work too:
+There are also C<Win32::IsWinNT()|Win32/Win32::IsWinNT()>,
+C<Win32::IsWin95()|Win32/Win32::IsWin95()>, and
+L<C<Win32::GetOSName()>|Win32/Win32::GetOSName()>; try
+L<C<perldoc Win32>|Win32>.
+The very portable L<C<POSIX::uname()>|POSIX/C<uname>> will work too:
c:\> perl -MPOSIX -we "print join '|', uname"
Windows NT|moonru|5.0|Build 2195 (Service Pack 2)|x86
In general, the easiest path to portability is always to specify
filenames in Unix format unless they will need to be processed by native
commands or utilities. Because of this latter consideration, the
-File::Spec module by default returns native format specifications
+L<File::Spec> module by default returns native format specifications
regardless of input format. This default may be reversed so that
filenames are always reported in Unix format by specifying the
C<DECC$FILENAME_UNIX_REPORT> feature logical in the environment.
The file type, or extension, is always present in a VMS-format file
specification even if it's zero-length. This means that, by default,
-C<readdir> will return a trailing dot on a file with no extension, so
-where you would see C<"a"> on Unix you'll see C<"a."> on VMS. However,
-the trailing dot may be suppressed by enabling the
-C<DECC$READDIR_DROPDOTNOTYPE> feature in the environment (see the CRTL
+L<C<readdir>|perlfunc/readdir DIRHANDLE> will return a trailing dot on a
+file with no extension, so where you would see C<"a"> on Unix you'll see
+C<"a."> on VMS. However, the trailing dot may be suppressed by enabling
+the C<DECC$READDIR_DROPDOTNOTYPE> feature in the environment (see the CRTL
documentation on feature logical names).
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 C<VMS::Stdio> module provides access to the
-special C<fopen()> requirements of files with unusual attributes on VMS.
+record format. The L<C<VMS::Stdio>|VMS::Stdio> module provides access to
+the special C<fopen()> requirements of files with unusual attributes on
+VMS.
-The value of C<$^O> on OpenVMS is "VMS". To determine the architecture
-that you are running on refer to C<$Config{'archname'}>.
+The value of L<C<$^O>|perlvar/$^O> on OpenVMS is "VMS". To determine the
+architecture that you are running on refer to
+L<C<$Config{archname}>|Config/C<archname>>.
On VMS, perl determines the UTC offset from the C<SYS$TIMEZONE_DIFFERENTIAL>
logical name. Although the VMS epoch began at 17-NOV-1858 00:00:00.00,
-calls to C<localtime> are adjusted to count offsets from
-01-JAN-1970 00:00:00.00, just like Unix.
+calls to L<C<localtime>|perlfunc/localtime EXPR> are adjusted to count
+offsets from 01-JAN-1970 00:00:00.00, just like Unix.
Also see:
Older releases of VOS (prior to OpenVOS Release 17.0) limit file
names to 32 or fewer characters, prohibit file names from
starting with a C<-> character, and prohibit file names from
-containing any character matching C<< tr/ !#%&'()*;<=>?// >>.
+containing C< > (space) or any character from the set C<< !#%&'()*;<=>? >>.
Newer releases of VOS (OpenVOS Release 17.0 or later) support a
feature known as extended names. On these releases, file names
can contain up to 255 characters, are prohibited from starting
with a C<-> character, and the set of prohibited characters is
-reduced to any character matching C<< tr/#%*<>?// >>. There are
+reduced to C<< #%*<>? >>. There are
restrictions involving spaces and apostrophes: these characters
must not begin or end a name, nor can they immediately precede or
follow a period. Additionally, a space must not immediately
to 255 characters, a path name is still limited to 256
characters.
-The value of C<$^O> on VOS is "vos". To determine the
-architecture that you are running on without resorting to loading
-all of C<%Config> you can examine the content of the C<@INC> array
-like so:
-
- if ($^O =~ /vos/) {
- print "I'm on a Stratus box!\n";
- } else {
- print "I'm not on a Stratus box!\n";
- die;
- }
+The value of L<C<$^O>|perlvar/$^O> on VOS is "vos". To determine the
+architecture that you are running on refer to
+L<C<$Config{archname}>|Config/C<archname>>.
Also see:
v5.22 core Perl runs on z/OS (formerly OS/390). Theoretically it could
run on the successors of OS/400 on AS/400 minicomputers as well as
VM/ESA, and BS2000 for S/390 Mainframes. Such computers use EBCDIC
-character sets internally (usually
-Character Code Set ID 0037 for OS/400 and either 1047 or POSIX-BC for S/390
-systems).
+character sets internally (usually Character Code Set ID 0037 for OS/400
+and either 1047 or POSIX-BC for S/390 systems).
The rest of this section may need updating, but we don't know what it
should say. Please email comments to
print "Hello from perl!\n";
OS/390 will support the C<#!> shebang trick in release 2.8 and beyond.
-Calls to C<system> and backticks can use POSIX shell syntax on all
-S/390 systems.
+Calls to L<C<system>|perlfunc/system LIST> and backticks can use POSIX
+shell syntax on all S/390 systems.
On the AS/400, if PERL5 is in your library list, you may need
to wrap your Perl scripts in a CL procedure to invoke them like so:
ENDPGM
This will invoke the Perl script F<hello.pl> in the root of the
-QOpenSys file system. On the AS/400 calls to C<system> or backticks
-must use CL syntax.
+QOpenSys file system. On the AS/400 calls to
+L<C<system>|perlfunc/system LIST> or backticks must use CL syntax.
On these platforms, bear in mind that the EBCDIC character set may have
-an effect on what happens with some Perl functions (such as C<chr>,
-C<pack>, C<print>, C<printf>, C<ord>, C<sort>, C<sprintf>, C<unpack>), as
-well as bit-fiddling with ASCII constants using operators like C<^>, C<&>
-and C<|>, not to mention dealing with socket interfaces to ASCII computers
-(see L</"Newlines">).
+an effect on what happens with some Perl functions (such as
+L<C<chr>|perlfunc/chr NUMBER>, L<C<pack>|perlfunc/pack TEMPLATE,LIST>,
+L<C<print>|perlfunc/print FILEHANDLE LIST>,
+L<C<printf>|perlfunc/printf FILEHANDLE FORMAT, LIST>,
+L<C<ord>|perlfunc/ord EXPR>, L<C<sort>|perlfunc/sort SUBNAME LIST>,
+L<C<sprintf>|perlfunc/sprintf FORMAT, LIST>,
+L<C<unpack>|perlfunc/unpack TEMPLATE,EXPR>), as
+well as bit-fiddling with ASCII constants using operators like
+L<C<^>, C<&> and C<|>|perlop/Bitwise String Operators>, not to mention
+dealing with socket interfaces to ASCII computers (see L</"Newlines">).
Fortunately, most web servers for the mainframe will correctly
translate the C<\n> in the following statement to its ASCII equivalent
print "Content-type: text/html\r\n\r\n";
-The values of C<$^O> on some of these platforms includes:
+The values of L<C<$^O>|perlvar/$^O> on some of these platforms include:
- uname $^O $Config{'archname'}
+ uname $^O $Config{archname}
--------------------------------------------
OS/390 os390 os390
OS400 os400 os400
Some simple tricks for determining if you are running on an EBCDIC
platform could include any of the following (perhaps all):
- if ("\t" eq "\005") { print "EBCDIC may be spoken here!\n"; }
+ if ("\t" eq "\005") { print "EBCDIC may be spoken here!\n"; }
if (ord('A') == 193) { print "EBCDIC may be spoken here!\n"; }
^ is the parent directory
Directory and File =~ m|[^\0- "\.\$\%\&:\@\\^\|\177]+|
-The default filename translation is roughly C<tr|/.|./|;>
+The default filename translation is roughly C<tr|/.|./|>, swapping dots
+and slahes.
Note that C<"ADFS::HardDisk.$.File" ne 'ADFS::HardDisk.$.File'> and that
the second stage of C<$> interpolation in regular expressions will fall
-foul of the C<$.> if scripts are not careful.
+foul of the L<C<$.>|perlvar/$.> variable if scripts are not careful.
Logical paths specified by system variables containing comma-separated
search lists are also allowed; hence C<System:Modules> is a valid
expand system variables in filenames if enclosed in angle brackets, so
C<< <System$Dir>.Modules >> would look for the file
S<C<$ENV{'System$Dir'} . 'Modules'>>. The obvious implication of this is
-that B<fully qualified filenames can start with C<< <> >>> and should
-be protected when C<open> is used for input.
+that B<fully qualified filenames can start with C<< <> >>> and the
+three-argument form of L<C<open>|perlfunc/open FILEHANDLE,EXPR> should
+always be used.
Because C<.> was in use as a directory separator and filenames could not
be assumed to be unique after 10 characters, Acorn implemented the C
that this sort of translation is required, and it allows a user-defined list
of known suffixes that it will transpose in this fashion. This may
seem transparent, but consider that with these rules F<foo/bar/baz.h>
-and F<foo/bar/h/baz> both map to F<foo.bar.h.baz>, and that C<readdir> and
-C<glob> cannot and do not attempt to emulate the reverse mapping. Other
+and F<foo/bar/h/baz> both map to F<foo.bar.h.baz>, and that
+L<C<readdir>|perlfunc/readdir DIRHANDLE> and L<C<glob>|perlfunc/glob EXPR>
+cannot and do not attempt to emulate the reverse mapping. Other
C<.>'s in filenames are translated to C</>.
-As implied above, the environment accessed through C<%ENV> is global, and
-the convention is that program specific environment variables are of the
-form C<Program$Name>. Each filesystem maintains a current directory,
+As implied above, the environment accessed through
+L<C<%ENV>|perlvar/%ENV> is global, and the convention is that program
+specific environment variables are of the form C<Program$Name>.
+Each filesystem maintains a current directory,
and the current filesystem's current directory is the B<global> current
directory. Consequently, sociable programs don't change the current
directory but rely on full pathnames, and programs (and Makefiles) cannot
The desire of users to express filenames of the form
C<< <Foo$Dir>.Bar >> on the command line unquoted causes problems,
-too: C<``> command output capture has to perform a guessing game. It
-assumes that a string C<< <[^<>]+\$[^<>]> >> is a
-reference to an environment variable, whereas anything else involving
+too: L<C<``>|perlop/C<qxE<sol>I<STRING>E<sol>>> command output capture has
+to perform a guessing game. It assumes that a string C<< <[^<>]+\$[^<>]> >>
+is a reference to an environment variable, whereas anything else involving
C<< < >> or C<< > >> is redirection, and generally manages to be 99%
right. Of course, the problem remains that scripts cannot rely on any
Unix tools being available, or that any tools found have Unix-like command
used to binary distributions. MakeMaker does run, but no available
make currently copes with MakeMaker's makefiles; even if and when
this should be fixed, the lack of a Unix-like shell will cause
-problems with makefile rules, especially lines of the form C<cd
-sdbm && make all>, and anything using quoting.
+problems with makefile rules, especially lines of the form
+C<cd sdbm && make all>, and anything using quoting.
-"S<RISC OS>" is the proper name for the operating system, but the value
-in C<$^O> is "riscos" (because we don't like shouting).
+S<"RISC OS"> is the proper name for the operating system, but the value
+in L<C<$^O>|perlvar/$^O> is "riscos" (because we don't like shouting).
=head2 Other perls
I<etc.> (Yes, we know that some of these OSes may fall under the
Unix category, but we are not a standards body.)
-Some approximate operating system names and their C<$^O> values
-in the "OTHER" category include:
+Some approximate operating system names and their L<C<$^O>|perlvar/$^O>
+values in the "OTHER" category include:
- OS $^O $Config{'archname'}
+ OS $^O $Config{archname}
------------------------------------------
Amiga DOS amigaos m68k-amigos
Listed below are functions that are either completely unimplemented
or else have been implemented differently on various platforms.
-Following each description will be, in parentheses, a list of
+Preceding each description will be, in parentheses, a list of
platforms that the description applies to.
The list may well be incomplete, or even wrong in some places. When
Be aware, moreover, that even among Unix-ish systems there are variations.
-For many functions, you can also query C<%Config>, exported by
-default from the C<Config> module. For example, to check whether the
-platform has the C<lstat> call, check C<$Config{d_lstat}>. See
-L<Config> for a full description of available variables.
+For many functions, you can also query L<C<%Config>|Config/DESCRIPTION>,
+exported by default from the L<C<Config>|Config> module. For example, to
+check whether the platform has the L<C<lstat>|perlfunc/lstat FILEHANDLE>
+call, check L<C<$Config{d_lstat}>|Config/C<d_lstat>>. See L<Config> for a
+full description of available variables.
=head2 Alphabetical Listing of Perl Functions
=item -X
+(Win32)
C<-w> only inspects the read-only file attribute (FILE_ATTRIBUTE_READONLY),
which determines whether the directory can be deleted, not whether it can
be written to. Directories always have read and write access unless denied
-by discretionary access control lists (DACLs). (S<Win32>)
+by discretionary access control lists (DACLs).
+(VMS)
C<-r>, C<-w>, C<-x>, and C<-o> tell whether the file is accessible,
-which may not reflect UIC-based file protections. (VMS)
+which may not reflect UIC-based file protections.
+(S<RISC OS>)
C<-s> by name on an open file will return the space reserved on disk,
rather than the current extent. C<-s> on an open filehandle returns the
-current size. (S<RISC OS>)
+current size.
+(Win32, VMS, S<RISC OS>)
C<-R>, C<-W>, C<-X>, C<-O> are indistinguishable from C<-r>, C<-w>,
-C<-x>, C<-o>. (Win32, VMS, S<RISC OS>)
+C<-x>, C<-o>.
-C<-g>, C<-k>, C<-l>, C<-u>, C<-A> are not particularly meaningful.
(Win32, VMS, S<RISC OS>)
+C<-g>, C<-k>, C<-l>, C<-u>, C<-A> are not particularly meaningful.
-C<-p> is not particularly meaningful. (VMS, S<RISC OS>)
+(VMS, S<RISC OS>)
+C<-p> is not particularly meaningful.
-C<-d> is true if passed a device spec without an explicit directory.
(VMS)
+C<-d> is true if passed a device spec without an explicit directory.
+(Win32)
C<-x> (or C<-X>) determine if a file ends in one of the executable
-suffixes. C<-S> is meaningless. (Win32)
+suffixes. C<-S> is meaningless.
-C<-x> (or C<-X>) determine if a file has an executable file type.
(S<RISC OS>)
+C<-x> (or C<-X>) determine if a file has an executable file type.
=item alarm
+(Win32)
Emulated using timers that must be explicitly polled whenever Perl
wants to dispatch "safe signals" and therefore cannot interrupt
-blocking system calls. (Win32)
+blocking system calls.
=item atan2
+(Tru64, HP-UX 10.20)
Due to issues with various CPUs, math libraries, compilers, and standards,
-results for C<atan2()> may vary depending on any combination of the above.
+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)
+returned from C<atan2>, but cannot force the issue if the system Perl is
+run on does not allow it.
-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
-Meaningless. (S<RISC OS>)
+(S<RISC OS>)
+Meaningless.
+(VMS)
Reopens file and restores pointer; if function fails, underlying
filehandle may be closed, or pointer may be in a different position.
-(VMS)
-The value returned by C<tell> may be affected after the call, and
-the filehandle may be flushed. (Win32)
+(Win32)
+The value returned by L<C<tell>|perlfunc/tell FILEHANDLE> may be affected
+after the call, and the filehandle may be flushed.
=item chmod
-Only good for changing "owner" read-write access, "group", and "other"
-bits are meaningless. (Win32)
+(Win32)
+Only good for changing "owner" read-write access; "group" and "other"
+bits are meaningless.
-Only good for changing "owner" and "other" read-write access. (S<RISC OS>)
+(S<RISC OS>)
+Only good for changing "owner" and "other" read-write access.
-Access permissions are mapped onto VOS access-control list changes. (VOS)
+(VOS)
+Access permissions are mapped onto VOS access-control list changes.
-The actual permissions set depend on the value of the C<CYGWIN>
-in the SYSTEM environment settings. (Cygwin)
+(Cygwin)
+The actual permissions set depend on the value of the C<CYGWIN> variable
+in the SYSTEM environment settings.
+(Android)
Setting the exec bit on some locations (generally F</sdcard>) will return true
-but not actually set the bit. (Android)
+but not actually set the bit.
=item chown
-Not implemented. (Win32, S<Plan 9>, S<RISC OS>)
+(S<Plan 9>, S<RISC OS>)
+Not implemented.
-Does nothing, but won't fail. (Win32)
+(Win32)
+Does nothing, but won't fail.
-A little funky, because VOS's notion of ownership is a little funky (VOS).
+(VOS)
+A little funky, because VOS's notion of ownership is a little funky.
=item chroot
-Not implemented. (Win32, VMS, S<Plan 9>, S<RISC OS>, VOS)
+(Win32, VMS, S<Plan 9>, S<RISC OS>, VOS)
+Not implemented.
=item crypt
+(Win32)
May not be available if library or source was not provided when building
-perl. (Win32)
+perl.
-Not implemented. (Android)
+(Android)
+Not implemented.
=item dbmclose
-Not implemented. (VMS, S<Plan 9>, VOS)
+(VMS, S<Plan 9>, VOS)
+Not implemented.
=item dbmopen
-Not implemented. (VMS, S<Plan 9>, VOS)
+(VMS, S<Plan 9>, VOS)
+Not implemented.
=item dump
-Not useful. (S<RISC OS>)
+(S<RISC OS>)
+Not useful.
-Not supported. (Cygwin, Win32)
+(Cygwin, Win32)
+Not supported.
-Invokes VMS debugger. (VMS)
+(VMS)
+Invokes VMS debugger.
=item exec
+(Win32)
C<exec LIST> without the use of indirect object syntax (C<exec PROGRAM LIST>)
-may fall back to trying the shell if the first C<spawn()> fails. (Win32)
+may fall back to trying the shell if the first C<spawn()> fails.
-Does not automatically flush output handles on some platforms.
(SunOS, Solaris, HP-UX)
+Does not automatically flush output handles on some platforms.
-Not supported. (Symbian OS)
+(Symbian OS)
+Not supported.
=item exit
-Emulates Unix C<exit()> (which considers C<exit 1> to indicate an error) by
+(VMS)
+Emulates Unix C<exit> (which considers C<exit 1> to indicate an error) by
mapping the C<1> to C<SS$_ABORT> (C<44>). This behavior may be overridden
-with the pragma C<use vmsish 'exit'>. As with the CRTL's C<exit()>
-function, C<exit 0> is also mapped to an exit status of C<SS$_NORMAL>
-(C<1>); this mapping cannot be overridden. Any other argument to
-C<exit()>
+with the pragma L<C<use vmsish 'exit'>|vmsish/C<vmsish exit>>. As with
+the CRTL's C<exit()> function, C<exit 0> is also mapped to an exit status
+of C<SS$_NORMAL> (C<1>); this mapping cannot be overridden. Any other
+argument to C<exit>
is used directly as Perl's exit status. On VMS, unless the future
POSIX_EXIT mode is enabled, the exit code should always be a valid
VMS exit code and not a generic number. When the POSIX_EXIT mode is
enabled, a generic number will be encoded in a method compatible with
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)
+programs, particularly ones written in C, like the GNV package.
-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)
+(Solaris)
+C<exit> resets file pointers, which is a problem when called
+from a child process (created by L<C<fork>|perlfunc/fork>) in
+L<C<BEGIN>|perlmod/BEGIN, UNITCHECK, CHECK, INIT and END>.
+A workaround is to use L<C<POSIX::_exit>|POSIX/C<_exit>>.
exit unless $Config{archname} =~ /\bsolaris\b/;
- require POSIX and POSIX::_exit(0);
+ require POSIX;
+ POSIX::_exit(0);
=item fcntl
-Not implemented. (Win32)
+(Win32)
+Not implemented.
-Some functions available based on the version of VMS. (VMS)
+(VMS)
+Some functions available based on the version of VMS.
=item flock
-Not implemented (VMS, S<RISC OS>, VOS).
+(VMS, S<RISC OS>, VOS)
+Not implemented.
=item fork
-Not implemented. (AmigaOS, S<RISC OS>, VMS)
+(AmigaOS, S<RISC OS>, VMS)
+Not implemented.
-Emulated using multiple interpreters. See L<perlfork>. (Win32)
+(Win32)
+Emulated using multiple interpreters. See L<perlfork>.
-Does not automatically flush output handles on some platforms.
(SunOS, Solaris, HP-UX)
+Does not automatically flush output handles on some platforms.
=item getlogin
-Not implemented. (S<RISC OS>)
+(S<RISC OS>)
+Not implemented.
=item getpgrp
-Not implemented. (Win32, VMS, S<RISC OS>)
+(Win32, VMS, S<RISC OS>)
+Not implemented.
=item getppid
-Not implemented. (Win32, S<RISC OS>)
+(Win32, S<RISC OS>)
+Not implemented.
=item getpriority
-Not implemented. (Win32, VMS, S<RISC OS>, VOS)
+(Win32, VMS, S<RISC OS>, VOS)
+Not implemented.
=item getpwnam
-Not implemented. (Win32)
+(Win32)
+Not implemented.
-Not useful. (S<RISC OS>)
+(S<RISC OS>)
+Not useful.
=item getgrnam
-Not implemented. (Win32, VMS, S<RISC OS>)
+(Win32, VMS, S<RISC OS>)
+Not implemented.
=item getnetbyname
-Not implemented. (Android, Win32, S<Plan 9>)
+(Android, Win32, S<Plan 9>)
+Not implemented.
=item getpwuid
-Not implemented. (Win32)
+(Win32)
+Not implemented.
-Not useful. (S<RISC OS>)
+(S<RISC OS>)
+Not useful.
=item getgrgid
-Not implemented. (Win32, VMS, S<RISC OS>)
+(Win32, VMS, S<RISC OS>)
+Not implemented.
=item getnetbyaddr
-Not implemented. (Android, Win32, S<Plan 9>)
+(Android, Win32, S<Plan 9>)
+Not implemented.
=item getprotobynumber
-Not implemented. (Android)
-
-=item getservbyport
+(Android)
+Not implemented.
=item getpwent
-Not implemented. (Android, Win32)
+(Android, Win32)
+Not implemented.
=item getgrent
-Not implemented. (Android, Win32, VMS)
+(Android, Win32, VMS)
+Not implemented.
=item gethostbyname
+(S<Irix 5>)
C<gethostbyname('localhost')> does not work everywhere: you may have
-to use C<gethostbyname('127.0.0.1')>. (S<Irix 5>)
+to use C<gethostbyname('127.0.0.1')>.
=item gethostent
-Not implemented. (Win32)
+(Win32)
+Not implemented.
=item getnetent
-Not implemented. (Android, Win32, S<Plan 9>)
+(Android, Win32, S<Plan 9>)
+Not implemented.
=item getprotoent
-Not implemented. (Android, Win32, S<Plan 9>)
+(Android, Win32, S<Plan 9>)
+Not implemented.
=item getservent
-Not implemented. (Win32, S<Plan 9>)
+(Win32, S<Plan 9>)
+Not implemented.
=item seekdir
-Not implemented. (Android)
+(Android)
+Not implemented.
=item sethostent
-Not implemented. (Android, Win32, S<Plan 9>, S<RISC OS>)
+(Android, Win32, S<Plan 9>, S<RISC OS>)
+Not implemented.
=item setnetent
-Not implemented. (Win32, S<Plan 9>, S<RISC OS>)
+(Win32, S<Plan 9>, S<RISC OS>)
+Not implemented.
=item setprotoent
-Not implemented. (Android, Win32, S<Plan 9>, S<RISC OS>)
+(Android, Win32, S<Plan 9>, S<RISC OS>)
+Not implemented.
=item setservent
-Not implemented. (S<Plan 9>, Win32, S<RISC OS>)
+(S<Plan 9>, Win32, S<RISC OS>)
+Not implemented.
=item endpwent
-Not implemented. (Win32)
+(Win32)
+Not implemented.
-Either not implemented or a no-op. (Android)
+(Android)
+Either not implemented or a no-op.
=item endgrent
-Not implemented. (Android, S<RISC OS>, VMS, Win32)
+(Android, S<RISC OS>, VMS, Win32)
+Not implemented.
=item endhostent
-Not implemented. (Android, Win32)
+(Android, Win32)
+Not implemented.
=item endnetent
-Not implemented. (Android, Win32, S<Plan 9>)
+(Android, Win32, S<Plan 9>)
+Not implemented.
=item endprotoent
-Not implemented. (Android, Win32, S<Plan 9>)
+(Android, Win32, S<Plan 9>)
+Not implemented.
=item endservent
-Not implemented. (S<Plan 9>, Win32)
+(S<Plan 9>, Win32)
+Not implemented.
-=item getsockopt SOCKET,LEVEL,OPTNAME
+=item getsockopt
-Not implemented. (S<Plan 9>)
+(S<Plan 9>)
+Not implemented.
=item glob
-This operator is implemented via the C<File::Glob> extension on most
-platforms. See L<File::Glob> for portability information.
+This operator is implemented via the L<C<File::Glob>|File::Glob> extension
+on most platforms. See L<File::Glob> for portability information.
=item gmtime
-In theory, C<gmtime()> is reliable from -2**63 to 2**63-1. However,
-because work arounds in the implementation use floating point numbers,
+In theory, C<gmtime> is reliable from -2**63 to 2**63-1. However,
+because work-arounds in the implementation use floating point numbers,
it will become inaccurate as the time gets larger. This is a bug and
will be fixed in the future.
-On VOS, time values are 32-bit quantities.
+(VOS)
+Time values are 32-bit quantities.
-=item ioctl FILEHANDLE,FUNCTION,SCALAR
+=item ioctl
-Not implemented. (VMS)
+(VMS)
+Not implemented.
+(Win32)
Available only for socket handles, and it does what the C<ioctlsocket()> call
-in the Winsock API does. (Win32)
+in the Winsock API does.
-Available only for socket handles. (S<RISC OS>)
+(S<RISC OS>)
+Available only for socket handles.
=item kill
-Not implemented, hence not useful for taint checking. (S<RISC OS>)
+(S<RISC OS>)
+Not implemented, hence not useful for taint checking.
-C<kill()> doesn't have the semantics of C<raise()>, i.e. it doesn't send
-a signal to the identified process like it does on Unix platforms.
-Instead C<kill($sig, $pid)> terminates the process identified by C<$pid>,
-and makes it exit immediately with exit status $sig. As in Unix, if
-$sig is 0 and the specified process exists, it returns true without
-actually terminating it. (Win32)
+(Win32)
+C<kill> doesn't send a signal to the identified process like it does on
+Unix platforms. Instead C<kill($sig, $pid)> terminates the process
+identified by C<$pid>, and makes it exit immediately with exit status
+C<$sig>. As in Unix, if C<$sig> is 0 and the specified process exists, it
+returns true without actually terminating it.
+(Win32)
C<kill(-9, $pid)> will terminate the process specified by C<$pid> and
recursively all child processes owned by it. This is different from
the Unix semantics, where the signal will be delivered to all
processes in the same process group as the process specified by
-$pid. (Win32)
+C<$pid>.
+(VMS)
A pid of -1 indicating all processes on the system is not currently
-supported. (VMS)
+supported.
=item link
-Not implemented. (S<RISC OS>, VOS)
+(S<RISC OS>, VOS)
+Not implemented.
+(AmigaOS)
Link count not updated because hard links are not quite that hard
-(They are sort of half-way between hard and soft links). (AmigaOS)
+(They are sort of half-way between hard and soft links).
+(Win32)
Hard links are implemented on Win32 under NTFS only. They are
natively supported on Windows 2000 and later. On Windows NT they
are implemented using the Windows POSIX subsystem support and the
Perl process will need Administrator or Backup Operator privileges
to create hard links.
-Available on 64 bit OpenVMS 8.2 and later. (VMS)
+(VMS)
+Available on 64 bit OpenVMS 8.2 and later.
=item localtime
-localtime() has the same range as L</gmtime>, but because time zone
-rules change its accuracy for historical and future times may degrade
+C<localtime> has the same range as L</gmtime>, but because time zone
+rules change, its accuracy for historical and future times may degrade
but usually by no more than an hour.
=item lstat
-Not implemented. (S<RISC OS>)
+(S<RISC OS>)
+Not implemented.
-Return values (especially for device and inode) may be bogus. (Win32)
+(Win32)
+Return values (especially for device and inode) may be bogus.
=item msgctl
=item msgrcv
-Not implemented. (Android, Win32, VMS, S<Plan 9>, S<RISC OS>, VOS)
+(Android, Win32, VMS, S<Plan 9>, S<RISC OS>, VOS)
+Not implemented.
=item open
-open to C<|-> and C<-|> are unsupported. (Win32, S<RISC OS>)
+(Win32, S<RISC OS>)
+Open modes C<|-> and C<-|> are unsupported.
+(SunOS, Solaris, HP-UX)
Opening a process does not automatically flush output handles on some
-platforms. (SunOS, Solaris, HP-UX)
+platforms.
=item readlink
-Not implemented. (Win32, VMS, S<RISC OS>)
+(Win32, VMS, S<RISC OS>)
+Not implemented.
=item rename
-Can't move directories between directories on different logical volumes. (Win32)
+(Win32)
+Can't move directories between directories on different logical volumes.
=item rewinddir
-Will not cause C<readdir()> to re-read the directory stream. The entries
-already read before the C<rewinddir()> call will just be returned again
-from a cache buffer. (Win32)
+(Win32)
+Will not cause L<C<readdir>|perlfunc/readdir DIRHANDLE> to re-read the
+directory stream. The entries already read before the C<rewinddir> call
+will just be returned again from a cache buffer.
=item select
-Only implemented on sockets. (Win32, VMS)
+(Win32, VMS)
+Only implemented on sockets.
-Only reliable on sockets. (S<RISC OS>)
+(S<RISC OS>)
+Only reliable on sockets.
-Note that the C<select FILEHANDLE> form is generally portable.
+Note that the L<C<select FILEHANDLE>|perlfunc/select FILEHANDLE> form is
+generally portable.
=item semctl
=item semop
-Not implemented. (Android, Win32, VMS, S<RISC OS>)
+(Android, Win32, VMS, S<RISC OS>)
+Not implemented.
=item setgrent
-Not implemented. (Android, VMS, Win32, S<RISC OS>)
+(Android, VMS, Win32, S<RISC OS>)
+Not implemented.
=item setpgrp
-Not implemented. (Win32, VMS, S<RISC OS>, VOS)
+(Win32, VMS, S<RISC OS>, VOS)
+Not implemented.
=item setpriority
-Not implemented. (Win32, VMS, S<RISC OS>, VOS)
+(Win32, VMS, S<RISC OS>, VOS)
+Not implemented.
=item setpwent
-Not implemented. (Android, Win32, S<RISC OS>)
+(Android, Win32, S<RISC OS>)
+Not implemented.
=item setsockopt
-Not implemented. (S<Plan 9>)
+(S<Plan 9>)
+Not implemented.
=item shmctl
=item shmwrite
-Not implemented. (Android, Win32, VMS, S<RISC OS>)
+(Android, Win32, VMS, S<RISC OS>)
+Not implemented.
=item sleep
+(Win32)
Emulated using synchronization functions such that it can be
-interrupted by C<alarm()>, and limited to a maximum of 4294967 seconds,
-approximately 49 days. (Win32)
-
-=item sockatmark
-
-A relatively recent addition to socket functions, may not
-be implemented even in Unix platforms.
+interrupted by L<C<alarm>|perlfunc/alarm SECONDS>, and limited to a
+maximum of 4294967 seconds, approximately 49 days.
=item socketpair
-Not implemented. (S<RISC OS>)
+(S<RISC OS>)
+Not implemented.
-Available on 64 bit OpenVMS 8.2 and later. (VMS)
+(VMS)
+Available on 64 bit OpenVMS 8.2 and later.
=item stat
-Platforms that do not have rdev, blksize, or blocks will return these
-as '', so numeric comparison or manipulation of these fields may cause
-'not numeric' warnings.
+Platforms that do not have C<rdev>, C<blksize>, or C<blocks> will return
+these as C<''>, so numeric comparison or manipulation of these fields may
+cause 'not numeric' warnings.
-ctime not supported on UFS (S<Mac OS X>).
+(S<Mac OS X>)
+C<ctime> not supported on UFS.
-ctime is creation time instead of inode change time (Win32).
+(Win32)
+C<ctime> is creation time instead of inode change time.
-device and inode are not meaningful. (Win32)
+(Win32)
+C<dev> and C<ino> are not meaningful.
-device and inode are not necessarily reliable. (VMS)
+(VMS)
+C<dev> and C<ino> are not necessarily reliable.
-mtime, atime and ctime all return the last modification time. Device and
-inode are not necessarily reliable. (S<RISC OS>)
+(S<RISC OS>)
+C<mtime>, C<atime> and C<ctime> all return the last modification time.
+C<dev> and C<ino> are not necessarily reliable.
-dev, rdev, blksize, and blocks are not available. inode is not
-meaningful and will differ between stat calls on the same file. (os2)
+(OS/2)
+C<dev>, C<rdev>, C<blksize>, and C<blocks> are not available. C<ino> is not
+meaningful and will differ between stat calls on the same file.
-some versions of cygwin when doing a C<stat("foo")> and if not finding it
-may then attempt to C<stat("foo.exe")> (Cygwin)
+(Cygwin)
+Some versions of cygwin when doing a C<stat("foo")> and not finding it
+may then attempt to C<stat("foo.exe")>.
-On Win32 C<stat()> needs to open the file to determine the link count
+(Win32)
+C<stat> needs to open the file to determine the link count
and update attributes that may have been changed through hard links.
-Setting C<${^WIN32_SLOPPY_STAT}> to a true value speeds up C<stat()> by
-not performing this operation. (Win32)
+Setting L<C<${^WIN32_SLOPPY_STAT}>|perlvar/${^WIN32_SLOPPY_STAT}> to a
+true value speeds up C<stat> by not performing this operation.
=item symlink
-Not implemented. (Win32, S<RISC OS>)
+(Win32, S<RISC OS>)
+Not implemented.
+(VMS)
Implemented on 64 bit VMS 8.3. VMS requires the symbolic link to be in Unix
syntax if it is intended to resolve to a valid path.
=item syscall
-Not implemented. (Win32, VMS, S<RISC OS>, VOS)
+(Win32, VMS, S<RISC OS>, VOS)
+Not implemented.
=item sysopen
-The traditional "0", "1", and "2" MODEs are implemented with different
-numeric values on some systems. The flags exported by C<Fcntl>
-(O_RDONLY, O_WRONLY, O_RDWR) should work everywhere though. (S<Mac
-OS>, OS/390)
+(S<Mac OS>, OS/390)
+The traditional C<0>, C<1>, and C<2> MODEs are implemented with different
+numeric values on some systems. The flags exported by L<C<Fcntl>|Fcntl>
+(C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR>) should work everywhere though.
=item system
+(Win32)
As an optimization, may not call the command shell specified in
C<$ENV{PERL5SHELL}>. C<system(1, @args)> spawns an external
process and immediately returns its process designator, without
waiting for it to terminate. Return value may be used subsequently
-in C<wait> or C<waitpid>. Failure to C<spawn()> a subprocess is indicated
-by setting C<$?> to S<C<"255 << 8">>. C<$?> is set in a way compatible with
-Unix (i.e. the exitstatus of the subprocess is obtained by S<C<"$? >> 8">>,
-as described in the documentation). (Win32)
+in L<C<wait>|perlfunc/wait> or L<C<waitpid>|perlfunc/waitpid PID,FLAGS>.
+Failure to C<spawn()> a subprocess is indicated by setting
+L<C<$?>|perlvar/$?> to C<<< 255 << 8 >>>. L<C<$?>|perlvar/$?> is set in a
+way compatible with Unix (i.e. the exit status of the subprocess is
+obtained by C<<< $? >> 8 >>>, as described in the documentation).
+(S<RISC OS>)
There is no shell to process metacharacters, and the native standard is
to pass a command line terminated by "\n" "\r" or "\0" to the spawned
program. Redirection such as C<< > foo >> is performed (if at all) by
-the run time library of the spawned program. C<system> I<list> will call
-the Unix emulation library's C<exec> emulation, which attempts to provide
-emulation of the stdin, stdout, stderr in force in the parent, providing
-the child program uses a compatible version of the emulation library.
-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>)
-
+the run time library of the spawned program. C<system LIST> will call
+the Unix emulation library's L<C<exec>|perlfunc/exec LIST> emulation,
+which attempts to provide emulation of the stdin, stdout, stderr in force
+in the parent, provided the child program uses a compatible version of the
+emulation library. C<system SCALAR> will call the native command line
+directly and no such emulation of a child Unix program will occur.
+Mileage B<will> vary.
+
+(Win32)
C<system LIST> without the use of indirect object syntax (C<system PROGRAM LIST>)
-may fall back to trying the shell if the first C<spawn()> fails. (Win32)
+may fall back to trying the shell if the first C<spawn()> fails.
-Does not automatically flush output handles on some platforms.
(SunOS, Solaris, HP-UX)
+Does not automatically flush output handles on some platforms.
+(VMS)
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'>).
-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)
+32-bit condition code (unless overridden by
+L<C<use vmsish 'status'>|vmsish/C<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/$?>.
=item telldir
-Not implemented. (Android)
+(Android)
+Not implemented.
=item times
-"cumulative" times will be bogus. On anything other than Windows NT
+(Win32)
+"Cumulative" times will be bogus. On anything other than Windows NT
or Windows 2000, "system" time will be bogus, and "user" time is
-actually the time returned by the C<clock()> function in the C runtime
-library. (Win32)
+actually the time returned by the L<C<clock()>|clock(3)> function in the C
+runtime library.
-Not useful. (S<RISC OS>)
+(S<RISC OS>)
+Not useful.
=item truncate
-Not implemented. (Older versions of VMS)
+(Older versions of VMS)
+Not implemented.
-Truncation to same-or-shorter lengths only. (VOS)
+(VOS)
+Truncation to same-or-shorter lengths only.
+(Win32)
If a FILEHANDLE is supplied, it must be writable and opened in append
-mode (i.e., use C<<< open(FH, '>>filename') >>>
-or C<sysopen(FH,...,O_APPEND|O_RDWR)>. If a filename is supplied, it
-should not be held open elsewhere. (Win32)
+mode (i.e., use C<<< open(my $fh, '>>', 'filename') >>>
+or C<sysopen(my $fh, ..., O_APPEND|O_RDWR)>. If a filename is supplied, it
+should not be held open elsewhere.
=item umask
-Returns undef where unavailable.
+Returns C<undef> where unavailable.
+(AmigaOS)
C<umask> works but the correct permissions are set only when the file
-is finally closed. (AmigaOS)
+is finally closed.
=item utime
-Only the modification time is updated. (VMS, S<RISC OS>)
+(VMS, S<RISC OS>)
+Only the modification time is updated.
+(Win32)
May not behave as expected. Behavior depends on the C runtime
-library's implementation of C<utime()>, and the filesystem being
-used. The FAT filesystem typically does not support an "access
-time" field, and it may limit timestamps to a granularity of
-two seconds. (Win32)
+library's implementation of L<C<utime()>|utime(2)>, and the filesystem
+being used. The FAT filesystem typically does not support an "access
+time" field, and it may limit timestamps to a granularity of two seconds.
=item wait
=item waitpid
+(Win32)
Can only be applied to process handles returned for processes spawned
-using C<system(1, ...)> or pseudo processes created with C<fork()>. (Win32)
+using C<system(1, ...)> or pseudo processes created with
+L<C<fork>|perlfunc/fork>.
-Not useful. (S<RISC OS>)
+(S<RISC OS>)
+Not useful.
=back
Andreas J. KE<ouml>nig <a.koenig@mind.de>,
Markus Laker <mlaker@contax.co.uk>,
Andrew M. Langmead <aml@world.std.com>,
+Lukas Mai <l.mai@web.de>,
Larry Moore <ljmoore@freespace.net>,
Paul Moore <Paul.Moore@uk.origin-it.com>,
Chris Nandor <pudge@pobox.com>,
=back
+=head2 Backtracking
+X<backtrack> X<backtracking>
+
+NOTE: This section presents an abstract approximation of regular
+expression behavior. For a more rigorous (and complicated) view of
+the rules involved in selecting a match among possible alternatives,
+see L</Combining RE Pieces>.
+
+A fundamental feature of regular expression matching involves the
+notion called I<backtracking>, which is currently used (when needed)
+by all regular non-possessive expression quantifiers, namely C<"*">, C<"*?">, C<"+">,
+C<"+?">, C<{n,m}>, and C<{n,m}?>. Backtracking is often optimized
+internally, but the general principle outlined here is valid.
+
+For a regular expression to match, the I<entire> regular expression must
+match, not just part of it. So if the beginning of a pattern containing a
+quantifier succeeds in a way that causes later parts in the pattern to
+fail, the matching engine backs up and recalculates the beginning
+part--that's why it's called backtracking.
+
+Here is an example of backtracking: Let's say you want to find the
+word following "foo" in the string "Food is on the foo table.":
+
+ $_ = "Food is on the foo table.";
+ if ( /\b(foo)\s+(\w+)/i ) {
+ print "$2 follows $1.\n";
+ }
+
+When the match runs, the first part of the regular expression (C<\b(foo)>)
+finds a possible match right at the beginning of the string, and loads up
+C<$1> with "Foo". However, as soon as the matching engine sees that there's
+no whitespace following the "Foo" that it had saved in C<$1>, it realizes its
+mistake and starts over again one character after where it had the
+tentative match. This time it goes all the way until the next occurrence
+of "foo". The complete regular expression matches this time, and you get
+the expected output of "table follows foo."
+
+Sometimes minimal matching can help a lot. Imagine you'd like to match
+everything between "foo" and "bar". Initially, you write something
+like this:
+
+ $_ = "The food is under the bar in the barn.";
+ if ( /foo(.*)bar/ ) {
+ print "got <$1>\n";
+ }
+
+Which perhaps unexpectedly yields:
+
+ got <d is under the bar in the >
+
+That's because C<.*> was greedy, so you get everything between the
+I<first> "foo" and the I<last> "bar". Here it's more effective
+to use minimal matching to make sure you get the text between a "foo"
+and the first "bar" thereafter.
+
+ if ( /foo(.*?)bar/ ) { print "got <$1>\n" }
+ got <d is under the >
+
+Here's another example. Let's say you'd like to match a number at the end
+of a string, and you also want to keep the preceding part of the match.
+So you write this:
+
+ $_ = "I have 2 numbers: 53147";
+ if ( /(.*)(\d*)/ ) { # Wrong!
+ print "Beginning is <$1>, number is <$2>.\n";
+ }
+
+That won't work at all, because C<.*> was greedy and gobbled up the
+whole string. As C<\d*> can match on an empty string the complete
+regular expression matched successfully.
+
+ Beginning is <I have 2 numbers: 53147>, number is <>.
+
+Here are some variants, most of which don't work:
+
+ $_ = "I have 2 numbers: 53147";
+ @pats = qw{
+ (.*)(\d*)
+ (.*)(\d+)
+ (.*?)(\d*)
+ (.*?)(\d+)
+ (.*)(\d+)$
+ (.*?)(\d+)$
+ (.*)\b(\d+)$
+ (.*\D)(\d+)$
+ };
+
+ for $pat (@pats) {
+ printf "%-12s ", $pat;
+ if ( /$pat/ ) {
+ print "<$1> <$2>\n";
+ } else {
+ print "FAIL\n";
+ }
+ }
+
+That will print out:
+
+ (.*)(\d*) <I have 2 numbers: 53147> <>
+ (.*)(\d+) <I have 2 numbers: 5314> <7>
+ (.*?)(\d*) <> <>
+ (.*?)(\d+) <I have > <2>
+ (.*)(\d+)$ <I have 2 numbers: 5314> <7>
+ (.*?)(\d+)$ <I have 2 numbers: > <53147>
+ (.*)\b(\d+)$ <I have 2 numbers: > <53147>
+ (.*\D)(\d+)$ <I have 2 numbers: > <53147>
+
+As you see, this can be a bit tricky. It's important to realize that a
+regular expression is merely a set of assertions that gives a definition
+of success. There may be 0, 1, or several different ways that the
+definition might succeed against a particular string. And if there are
+multiple ways it might succeed, you need to understand backtracking to
+know which variety of success you will achieve.
+
+When using lookahead assertions and negations, this can all get even
+trickier. Imagine you'd like to find a sequence of non-digits not
+followed by "123". You might try to write that as
+
+ $_ = "ABC123";
+ if ( /^\D*(?!123)/ ) { # Wrong!
+ print "Yup, no 123 in $_\n";
+ }
+
+But that isn't going to match; at least, not the way you're hoping. It
+claims that there is no 123 in the string. Here's a clearer picture of
+why that pattern matches, contrary to popular expectations:
+
+ $x = 'ABC123';
+ $y = 'ABC445';
+
+ print "1: got $1\n" if $x =~ /^(ABC)(?!123)/;
+ print "2: got $1\n" if $y =~ /^(ABC)(?!123)/;
+
+ print "3: got $1\n" if $x =~ /^(\D*)(?!123)/;
+ print "4: got $1\n" if $y =~ /^(\D*)(?!123)/;
+
+This prints
+
+ 2: got ABC
+ 3: got AB
+ 4: got ABC
+
+You might have expected test 3 to fail because it seems to a more
+general purpose version of test 1. The important difference between
+them is that test 3 contains a quantifier (C<\D*>) and so can use
+backtracking, whereas test 1 will not. What's happening is
+that you've asked "Is it true that at the start of C<$x>, following 0 or more
+non-digits, you have something that's not 123?" If the pattern matcher had
+let C<\D*> expand to "ABC", this would have caused the whole pattern to
+fail.
+
+The search engine will initially match C<\D*> with "ABC". Then it will
+try to match C<(?!123)> with "123", which fails. But because
+a quantifier (C<\D*>) has been used in the regular expression, the
+search engine can backtrack and retry the match differently
+in the hope of matching the complete regular expression.
+
+The pattern really, I<really> wants to succeed, so it uses the
+standard pattern back-off-and-retry and lets C<\D*> expand to just "AB" this
+time. Now there's indeed something following "AB" that is not
+"123". It's "C123", which suffices.
+
+We can deal with this by using both an assertion and a negation.
+We'll say that the first part in C<$1> must be followed both by a digit
+and by something that's not "123". Remember that the lookaheads
+are zero-width expressions--they only look, but don't consume any
+of the string in their match. So rewriting this way produces what
+you'd expect; that is, case 5 will fail, but case 6 succeeds:
+
+ print "5: got $1\n" if $x =~ /^(\D*)(?=\d)(?!123)/;
+ print "6: got $1\n" if $y =~ /^(\D*)(?=\d)(?!123)/;
+
+ 6: got ABC
+
+In other words, the two zero-width assertions next to each other work as though
+they're ANDed together, just as you'd use any built-in assertions: C</^$/>
+matches only if you're at the beginning of the line AND the end of the
+line simultaneously. The deeper underlying truth is that juxtaposition in
+regular expressions always means AND, except when you write an explicit OR
+using the vertical bar. C</ab/> means match "a" AND (then) match "b",
+although the attempted matches are made at different positions because "a"
+is not a zero-width assertion, but a one-width assertion.
+
+B<WARNING>: Particularly complicated regular expressions can take
+exponential time to solve because of the immense number of possible
+ways they can use backtracking to try for a match. For example, without
+internal optimizations done by the regular expression engine, this will
+take a painfully long time to run:
+
+ 'aaaaaaaaaaaa' =~ /((a{0,5}){0,5})*[c]/
+
+And if you used C<"*">'s in the internal groups instead of limiting them
+to 0 through 5 matches, then it would take forever--or until you ran
+out of stack space. Moreover, these internal optimizations are not
+always applicable. For example, if you put C<{0,5}> instead of C<"*">
+on the external group, no current optimization is applicable, and the
+match takes a long time to finish.
+
+A powerful tool for optimizing such beasts is what is known as an
+"independent group",
+which does not backtrack (see L</C<< (?>pattern) >>>). Note also that
+zero-length lookahead/lookbehind assertions will not backtrack to make
+the tail match, since they are in "logical" context: only
+whether they match is considered relevant. For an example
+where side-effects of lookahead I<might> have influenced the
+following match, see L</C<< (?>pattern) >>>.
+
=head2 Special Backtracking Control Verbs
These special patterns are generally of the form C<(*I<VERB>:I<ARG>)>. Unless
=back
-=head2 Backtracking
-X<backtrack> X<backtracking>
-
-NOTE: This section presents an abstract approximation of regular
-expression behavior. For a more rigorous (and complicated) view of
-the rules involved in selecting a match among possible alternatives,
-see L</Combining RE Pieces>.
-
-A fundamental feature of regular expression matching involves the
-notion called I<backtracking>, which is currently used (when needed)
-by all regular non-possessive expression quantifiers, namely C<"*">, C<"*?">, C<"+">,
-C<"+?">, C<{n,m}>, and C<{n,m}?>. Backtracking is often optimized
-internally, but the general principle outlined here is valid.
-
-For a regular expression to match, the I<entire> regular expression must
-match, not just part of it. So if the beginning of a pattern containing a
-quantifier succeeds in a way that causes later parts in the pattern to
-fail, the matching engine backs up and recalculates the beginning
-part--that's why it's called backtracking.
-
-Here is an example of backtracking: Let's say you want to find the
-word following "foo" in the string "Food is on the foo table.":
-
- $_ = "Food is on the foo table.";
- if ( /\b(foo)\s+(\w+)/i ) {
- print "$2 follows $1.\n";
- }
-
-When the match runs, the first part of the regular expression (C<\b(foo)>)
-finds a possible match right at the beginning of the string, and loads up
-C<$1> with "Foo". However, as soon as the matching engine sees that there's
-no whitespace following the "Foo" that it had saved in C<$1>, it realizes its
-mistake and starts over again one character after where it had the
-tentative match. This time it goes all the way until the next occurrence
-of "foo". The complete regular expression matches this time, and you get
-the expected output of "table follows foo."
-
-Sometimes minimal matching can help a lot. Imagine you'd like to match
-everything between "foo" and "bar". Initially, you write something
-like this:
-
- $_ = "The food is under the bar in the barn.";
- if ( /foo(.*)bar/ ) {
- print "got <$1>\n";
- }
-
-Which perhaps unexpectedly yields:
-
- got <d is under the bar in the >
-
-That's because C<.*> was greedy, so you get everything between the
-I<first> "foo" and the I<last> "bar". Here it's more effective
-to use minimal matching to make sure you get the text between a "foo"
-and the first "bar" thereafter.
-
- if ( /foo(.*?)bar/ ) { print "got <$1>\n" }
- got <d is under the >
-
-Here's another example. Let's say you'd like to match a number at the end
-of a string, and you also want to keep the preceding part of the match.
-So you write this:
-
- $_ = "I have 2 numbers: 53147";
- if ( /(.*)(\d*)/ ) { # Wrong!
- print "Beginning is <$1>, number is <$2>.\n";
- }
-
-That won't work at all, because C<.*> was greedy and gobbled up the
-whole string. As C<\d*> can match on an empty string the complete
-regular expression matched successfully.
-
- Beginning is <I have 2 numbers: 53147>, number is <>.
-
-Here are some variants, most of which don't work:
-
- $_ = "I have 2 numbers: 53147";
- @pats = qw{
- (.*)(\d*)
- (.*)(\d+)
- (.*?)(\d*)
- (.*?)(\d+)
- (.*)(\d+)$
- (.*?)(\d+)$
- (.*)\b(\d+)$
- (.*\D)(\d+)$
- };
-
- for $pat (@pats) {
- printf "%-12s ", $pat;
- if ( /$pat/ ) {
- print "<$1> <$2>\n";
- } else {
- print "FAIL\n";
- }
- }
-
-That will print out:
-
- (.*)(\d*) <I have 2 numbers: 53147> <>
- (.*)(\d+) <I have 2 numbers: 5314> <7>
- (.*?)(\d*) <> <>
- (.*?)(\d+) <I have > <2>
- (.*)(\d+)$ <I have 2 numbers: 5314> <7>
- (.*?)(\d+)$ <I have 2 numbers: > <53147>
- (.*)\b(\d+)$ <I have 2 numbers: > <53147>
- (.*\D)(\d+)$ <I have 2 numbers: > <53147>
-
-As you see, this can be a bit tricky. It's important to realize that a
-regular expression is merely a set of assertions that gives a definition
-of success. There may be 0, 1, or several different ways that the
-definition might succeed against a particular string. And if there are
-multiple ways it might succeed, you need to understand backtracking to
-know which variety of success you will achieve.
-
-When using lookahead assertions and negations, this can all get even
-trickier. Imagine you'd like to find a sequence of non-digits not
-followed by "123". You might try to write that as
-
- $_ = "ABC123";
- if ( /^\D*(?!123)/ ) { # Wrong!
- print "Yup, no 123 in $_\n";
- }
-
-But that isn't going to match; at least, not the way you're hoping. It
-claims that there is no 123 in the string. Here's a clearer picture of
-why that pattern matches, contrary to popular expectations:
-
- $x = 'ABC123';
- $y = 'ABC445';
-
- print "1: got $1\n" if $x =~ /^(ABC)(?!123)/;
- print "2: got $1\n" if $y =~ /^(ABC)(?!123)/;
-
- print "3: got $1\n" if $x =~ /^(\D*)(?!123)/;
- print "4: got $1\n" if $y =~ /^(\D*)(?!123)/;
-
-This prints
-
- 2: got ABC
- 3: got AB
- 4: got ABC
-
-You might have expected test 3 to fail because it seems to a more
-general purpose version of test 1. The important difference between
-them is that test 3 contains a quantifier (C<\D*>) and so can use
-backtracking, whereas test 1 will not. What's happening is
-that you've asked "Is it true that at the start of C<$x>, following 0 or more
-non-digits, you have something that's not 123?" If the pattern matcher had
-let C<\D*> expand to "ABC", this would have caused the whole pattern to
-fail.
-
-The search engine will initially match C<\D*> with "ABC". Then it will
-try to match C<(?!123)> with "123", which fails. But because
-a quantifier (C<\D*>) has been used in the regular expression, the
-search engine can backtrack and retry the match differently
-in the hope of matching the complete regular expression.
-
-The pattern really, I<really> wants to succeed, so it uses the
-standard pattern back-off-and-retry and lets C<\D*> expand to just "AB" this
-time. Now there's indeed something following "AB" that is not
-"123". It's "C123", which suffices.
-
-We can deal with this by using both an assertion and a negation.
-We'll say that the first part in C<$1> must be followed both by a digit
-and by something that's not "123". Remember that the lookaheads
-are zero-width expressions--they only look, but don't consume any
-of the string in their match. So rewriting this way produces what
-you'd expect; that is, case 5 will fail, but case 6 succeeds:
-
- print "5: got $1\n" if $x =~ /^(\D*)(?=\d)(?!123)/;
- print "6: got $1\n" if $y =~ /^(\D*)(?=\d)(?!123)/;
-
- 6: got ABC
-
-In other words, the two zero-width assertions next to each other work as though
-they're ANDed together, just as you'd use any built-in assertions: C</^$/>
-matches only if you're at the beginning of the line AND the end of the
-line simultaneously. The deeper underlying truth is that juxtaposition in
-regular expressions always means AND, except when you write an explicit OR
-using the vertical bar. C</ab/> means match "a" AND (then) match "b",
-although the attempted matches are made at different positions because "a"
-is not a zero-width assertion, but a one-width assertion.
-
-B<WARNING>: Particularly complicated regular expressions can take
-exponential time to solve because of the immense number of possible
-ways they can use backtracking to try for a match. For example, without
-internal optimizations done by the regular expression engine, this will
-take a painfully long time to run:
-
- 'aaaaaaaaaaaa' =~ /((a{0,5}){0,5})*[c]/
-
-And if you used C<"*">'s in the internal groups instead of limiting them
-to 0 through 5 matches, then it would take forever--or until you ran
-out of stack space. Moreover, these internal optimizations are not
-always applicable. For example, if you put C<{0,5}> instead of C<"*">
-on the external group, no current optimization is applicable, and the
-match takes a long time to finish.
-
-A powerful tool for optimizing such beasts is what is known as an
-"independent group",
-which does not backtrack (see L</C<< (?>pattern) >>>). Note also that
-zero-length lookahead/lookbehind assertions will not backtrack to make
-the tail match, since they are in "logical" context: only
-whether they match is considered relevant. For an example
-where side-effects of lookahead I<might> have influenced the
-following match, see L</C<< (?>pattern) >>>.
-
=head2 Version 8 Regular Expressions
X<regular expression, version 8> X<regex, version 8> X<regexp, version 8>
=item B<-D>I<number>
-sets debugging flags. To watch how it executes your program, use
-B<-Dtls>. (This works only if debugging is compiled into your
-Perl.) Another nice value is B<-Dx>, which lists your compiled
-syntax tree. And B<-Dr> displays compiled regular expressions;
-the format of the output is explained in L<perldebguts>.
+sets debugging flags. This switch is enabled only if your perl binary has
+been built with debugging enabled: normal production perls won't have
+been.
+
+For example, to watch how perl executes your program, use B<-Dtls>.
+Another nice value is B<-Dx>, which lists your compiled syntax tree, and
+B<-Dr> displays compiled regular expressions; the format of the output is
+explained in L<perldebguts>.
As an alternative, specify a number instead of list of letters (e.g.,
B<-D14> is equivalent to B<-Dtls>):
executable (but see C<:opd> in L<Devel::Peek> or L<re/'debug' mode>
which may change this).
See the F<INSTALL> file in the Perl source distribution
-for how to do this. This flag is automatically set if you include B<-g>
-option when C<Configure> asks you about optimizer/debugger flags.
+for how to do this.
If you're just trying to get a print out of each line of Perl code
as it executes, the way that C<sh -x> provides for shell scripts,
a later release needed more code points than the available extras, and a
new block had to allocated somewhere else, not contiguous to the initial
one, to handle the overflow. Thus, it became apparent early on that
-"block" wasn't an adequate organizing principal, and so the C<Script>
+"block" wasn't an adequate organizing principle, and so the C<Script>
property was created. (Later an improved script property was added as
well, the C<Script_Extensions> property.) Those code points that are in
overflow blocks can still
See the documentation of C<use VERSION> and C<require VERSION>
for a convenient way to fail if the running Perl interpreter is too old.
-See also C<$]> for a decimal representation of the Perl version.
+See also C<L</$]>> for a decimal representation of the Perl version.
The main advantage of C<$^V> over C<$]> is that, for Perl v5.10.0 or
later, it overloads operators, allowing easy comparison against other
version representations (e.g. decimal, literal v-string, "v1.2.3", or
objects). The disadvantage is that prior to v5.10.0, it was only a
-literal v-string, which can't be easily printed or compared.
+literal v-string, which can't be easily printed or compared, whereas
+the behavior of C<$]> is unchanged on all versions of Perl.
Mnemonic: use ^V for a version object.
sv_usepvn(temp, pv, llen);
little_p = SvPVX(little);
} else {
- temp = little_utf8
- ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
+ temp = newSVpvn(little_p, llen);
sv_utf8_upgrade(temp);
- if (little_utf8) {
- big = temp;
- big_utf8 = TRUE;
- big_p = SvPV_const(big, biglen);
- } else {
- little = temp;
- little_p = SvPV_const(little, llen);
- }
+ little = temp;
+ little_p = SvPV_const(little, llen);
}
}
if (SvGAMAGIC(big)) {
* allocate without allocating too much. Such is life.
* See corresponding comment in lc code for another option
* */
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
+ d = o + (U8*) SvGROW(dest, min);
}
Copy(tmpbuf, d, ulen, U8);
d += ulen;
* ASCII. If not enough room, grow the string */
if (SvLEN(dest) < ++min) {
const UV o = d - (U8*)SvPVX_const(dest);
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
+ d = o + (U8*) SvGROW(dest, min);
}
*d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
continue; /* Back to the tight loop; still in ASCII */
* Another option would be to grow an extra byte or two more
* each time we need to grow, which would cut down the million
* to 500K, with little waste */
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
+ d = o + (U8*) SvGROW(dest, min);
}
/* Copy the newly lowercased letter to the output buffer we're
if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
const UV o = d - (U8*)SvPVX_const(dest);
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
+ d = o + (U8*) SvGROW(dest, min);
}
Copy(tmpbuf, d, ulen, U8);
* becomes "ss", which may require growing the SV. */
if (SvLEN(dest) < ++min) {
const UV o = d - (U8*)SvPVX_const(dest);
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
+ d = o + (U8*) SvGROW(dest, min);
}
*(d)++ = 's';
*d = 's';
}
-/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
+/* used for: pp_padany(), pp_custom(); plus any system ops
* that aren't implemented on a particular platform */
PP(unimplemented_op)
RETURN;
}
+
+/* process one subroutine argument - typically when the sub has a signature:
+ * introduce PL_curpad[op_targ] and assign to it the value
+ * for $: (OPf_STACKED ? *sp : $_[N])
+ * for @/%: @_[N..$#_]
+ *
+ * It's equivalent to
+ * my $foo = $_[N];
+ * or
+ * my $foo = (value-on-stack)
+ * or
+ * my @foo = @_[N..$#_]
+ * etc
+ */
+
+PP(pp_argelem)
+{
+ dTARG;
+ SV *val;
+ SV ** padentry;
+ OP *o = PL_op;
+ AV *defav = GvAV(PL_defgv); /* @_ */
+ IV ix = PTR2IV(cUNOP_AUXo->op_aux);
+ IV argc;
+
+ /* do 'my $var, @var or %var' action */
+ padentry = &(PAD_SVl(o->op_targ));
+ save_clearsv(padentry);
+ targ = *padentry;
+
+ if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
+ if (o->op_flags & OPf_STACKED) {
+ dSP;
+ val = POPs;
+ PUTBACK;
+ }
+ else {
+ SV **svp;
+ /* should already have been checked */
+ assert(ix >= 0);
+#if IVSIZE > PTRSIZE
+ assert(ix <= SSize_t_MAX);
+#endif
+
+ svp = av_fetch(defav, ix, FALSE);
+ val = svp ? *svp : &PL_sv_undef;
+ }
+
+ /* $var = $val */
+
+ /* cargo-culted from pp_sassign */
+ assert(TAINTING_get || !TAINT_get);
+ if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
+ TAINT_NOT;
+
+ SvSetMagicSV(targ, val);
+ return o->op_next;
+ }
+
+ /* must be AV or HV */
+
+ assert(!(o->op_flags & OPf_STACKED));
+ argc = ((IV)AvFILL(defav) + 1) - ix;
+
+ /* This is a copy of the relevant parts of pp_aassign().
+ */
+ if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
+ IV i;
+
+ if (AvFILL((AV*)targ) > -1) {
+ /* target should usually be empty. If we get get
+ * here, someone's been doing some weird closure tricks.
+ * Make a copy of all args before clearing the array,
+ * to avoid the equivalent of @a = ($a[0]) prematurely freeing
+ * elements. See similar code in pp_aassign.
+ */
+ for (i = 0; i < argc; i++) {
+ SV **svp = av_fetch(defav, ix + i, FALSE);
+ SV *newsv = newSV(0);
+ sv_setsv_flags(newsv,
+ svp ? *svp : &PL_sv_undef,
+ (SV_DO_COW_SVSETSV|SV_NOSTEAL));
+ if (!av_store(defav, ix + i, newsv))
+ SvREFCNT_dec_NN(newsv);
+ }
+ av_clear((AV*)targ);
+ }
+
+ if (argc <= 0)
+ return o->op_next;
+
+ av_extend((AV*)targ, argc);
+
+ i = 0;
+ while (argc--) {
+ SV *tmpsv;
+ SV **svp = av_fetch(defav, ix + i, FALSE);
+ SV *val = svp ? *svp : &PL_sv_undef;
+ tmpsv = newSV(0);
+ sv_setsv(tmpsv, val);
+ av_store((AV*)targ, i++, tmpsv);
+ TAINT_NOT;
+ }
+
+ }
+ else {
+ IV i;
+
+ assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
+
+ if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
+ /* see "target should usually be empty" comment above */
+ for (i = 0; i < argc; i++) {
+ SV **svp = av_fetch(defav, ix + i, FALSE);
+ SV *newsv = newSV(0);
+ sv_setsv_flags(newsv,
+ svp ? *svp : &PL_sv_undef,
+ (SV_DO_COW_SVSETSV|SV_NOSTEAL));
+ if (!av_store(defav, ix + i, newsv))
+ SvREFCNT_dec_NN(newsv);
+ }
+ hv_clear((HV*)targ);
+ }
+
+ if (argc <= 0)
+ return o->op_next;
+ assert(argc % 2 == 0);
+
+ i = 0;
+ while (argc) {
+ SV *tmpsv;
+ SV **svp;
+ SV *key;
+ SV *val;
+
+ svp = av_fetch(defav, ix + i++, FALSE);
+ key = svp ? *svp : &PL_sv_undef;
+ svp = av_fetch(defav, ix + i++, FALSE);
+ val = svp ? *svp : &PL_sv_undef;
+
+ argc -= 2;
+ if (UNLIKELY(SvGMAGICAL(key)))
+ key = sv_mortalcopy(key);
+ tmpsv = newSV(0);
+ sv_setsv(tmpsv, val);
+ hv_store_ent((HV*)targ, key, tmpsv, 0);
+ TAINT_NOT;
+ }
+ }
+
+ return o->op_next;
+}
+
+/* Handle a default value for one subroutine argument (typically as part
+ * of a subroutine signature).
+ * It's equivalent to
+ * @_ > op_targ ? $_[op_targ] : result_of(op_other)
+ *
+ * Intended to be used where op_next is an OP_ARGELEM
+ *
+ * We abuse the op_targ field slightly: it's an index into @_ rather than
+ * into PL_curpad.
+ */
+
+PP(pp_argdefelem)
+{
+ OP * const o = PL_op;
+ AV *defav = GvAV(PL_defgv); /* @_ */
+ IV ix = (IV)o->op_targ;
+
+ assert(ix >= 0);
+#if IVSIZE > PTRSIZE
+ assert(ix <= SSize_t_MAX);
+#endif
+
+ if (AvFILL(defav) >= ix) {
+ dSP;
+ SV **svp = av_fetch(defav, ix, FALSE);
+ SV *val = svp ? *svp : &PL_sv_undef;
+ XPUSHs(val);
+ RETURN;
+ }
+ return cLOGOPo->op_other;
+}
+
+
+
+/* Check a a subs arguments - i.e. that it has the correct number of args
+ * (and anything else we might think of in future). Typically used with
+ * signatured subs.
+ */
+
+PP(pp_argcheck)
+{
+ OP * const o = PL_op;
+ UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
+ IV params = aux[0].iv;
+ IV opt_params = aux[1].iv;
+ char slurpy = (char)(aux[2].iv);
+ AV *defav = GvAV(PL_defgv); /* @_ */
+ IV argc;
+ bool too_few;
+
+ assert(!SvMAGICAL(defav));
+ argc = (AvFILLp(defav) + 1);
+ too_few = (argc < (params - opt_params));
+
+ if (UNLIKELY(too_few || (!slurpy && argc > params)))
+ /* diag_listed_as: Too few arguments for subroutine */
+ /* diag_listed_as: Too many arguments for subroutine */
+ Perl_croak_caller("Too %s arguments for subroutine",
+ too_few ? "few" : "many");
+
+ if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
+ Perl_croak_caller("Odd name/value argument for subroutine");
+
+
+ return NORMAL;
+}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
#define MARK mark
#define TARG targ
-#if defined(DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS)
-
-# define PUSHMARK(p) \
+#define PUSHMARK(p) \
STMT_START { \
I32 * mark_stack_entry; \
if (UNLIKELY((mark_stack_entry = ++PL_markstack_ptr) \
PL_markstack_ptr, (IV)*mark_stack_entry))); \
} STMT_END
-# define TOPMARK \
- ({ \
- DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, \
- "MARK top %p %"IVdf"\n", \
- PL_markstack_ptr, (IV)*PL_markstack_ptr))); \
- *PL_markstack_ptr; \
- })
+#define TOPMARK S_TOPMARK(aTHX)
+#define POPMARK S_POPMARK(aTHX)
-# define POPMARK \
- ({ \
- DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, \
- "MARK pop %p %"IVdf"\n", \
- (PL_markstack_ptr-1), (IV)*(PL_markstack_ptr-1)))); \
- assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");\
- *PL_markstack_ptr--; \
- })
-
-# define INCMARK \
- ({ \
+#define INCMARK \
+ STMT_START { \
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, \
"MARK inc %p %"IVdf"\n", \
(PL_markstack_ptr+1), (IV)*(PL_markstack_ptr+1)))); \
- *PL_markstack_ptr++; \
- })
-
-#else
-
-# define PUSHMARK(p) \
- STMT_START { \
- I32 * mark_stack_entry; \
- if (UNLIKELY((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max)) \
- mark_stack_entry = markstack_grow(); \
- *mark_stack_entry = (I32)((p) - PL_stack_base); \
+ PL_markstack_ptr++; \
} STMT_END
-# define TOPMARK (*PL_markstack_ptr)
-# define POPMARK (*PL_markstack_ptr--)
-# define INCMARK (*PL_markstack_ptr++)
-#endif
#define dSP SV **sp = PL_stack_sp
#define djSP dSP
}
}
+/* also used for: pp_mapstart() */
PP(pp_grepstart)
{
dSP;
static void
S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
{
- SV *namesv;
+ SV *namesv = NULL; /* init to avoid dumb compiler warning */
bool do_croak;
CX_LEAVE_SCOPE(cx);
/* inlined av_fetch() for simple cases ... */
if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
sv = AvARRAY(av)[key];
- if (sv && !SvIS_FREED(sv)) {
+ if (sv) {
PUSHs(sv);
RETURN;
}
}
}
+
+
+/* like croak, but report in context of caller */
+
+void
+Perl_croak_caller(const char *pat, ...)
+{
+ dTHX;
+ va_list args;
+ const PERL_CONTEXT *cx = caller_cx(0, NULL);
+
+ /* make error appear at call site */
+ assert(cx);
+ PL_curcop = cx->blk_oldcop;
+
+ va_start(args, pat);
+ vcroak(pat, &args);
+ NOT_REACHED; /* NOTREACHED */
+ va_end(args);
+}
+
+
PP(pp_aelem)
{
dSP;
* of pack() (and all copies of the result) are
* gone.
*/
- if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
+ if (((SvTEMP(fromstr) && SvREFCNT(fromstr) == 1)
+ || (SvPADTMP(fromstr) &&
!SvREADONLY(fromstr)))) {
Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
"Attempt to pack pointer to temporary value");
PERL_CALLCONV OP *Perl_pp_anonconst(pTHX);
PERL_CALLCONV OP *Perl_pp_anonhash(pTHX);
PERL_CALLCONV OP *Perl_pp_anonlist(pTHX);
+PERL_CALLCONV OP *Perl_pp_argcheck(pTHX);
+PERL_CALLCONV OP *Perl_pp_argdefelem(pTHX);
+PERL_CALLCONV OP *Perl_pp_argelem(pTHX);
PERL_CALLCONV OP *Perl_pp_aslice(pTHX);
PERL_CALLCONV OP *Perl_pp_atan2(pTHX);
PERL_CALLCONV OP *Perl_pp_av2arylen(pTHX);
bool hasargs = FALSE;
bool copytmps;
I32 is_xsub = 0;
- I32 sorting_av = 0;
const U8 priv = PL_op->op_private;
const U8 flags = PL_op->op_flags;
U32 sort_flags = 0;
PL_sortcop = NULL;
}
- /* optimiser converts "@a = sort @a" to "sort \@a";
- * in case of tied @a, pessimise: push (@a) onto stack, then assign
- * result back to @a at the end of this function */
+ /* optimiser converts "@a = sort @a" to "sort \@a". In this case,
+ * push (@a) onto stack, then assign result back to @a at the end of
+ * this function */
if (priv & OPpSORT_INPLACE) {
assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
(void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
av = MUTABLE_AV((*SP));
+ if (SvREADONLY(av))
+ Perl_croak_no_modify();
max = AvFILL(av) + 1;
+ MEXTEND(SP, max);
if (SvMAGICAL(av)) {
- MEXTEND(SP, max);
for (i=0; i < max; i++) {
SV **svp = av_fetch(av, i, FALSE);
*SP++ = (svp) ? *svp : NULL;
}
- SP--;
- p1 = p2 = SP - (max-1);
}
- else {
- if (SvREADONLY(av))
- Perl_croak_no_modify();
- else
- {
- SvREADONLY_on(av);
- save_pushptr((void *)av, SAVEt_READONLY_OFF);
- }
- p1 = p2 = AvARRAY(av);
- sorting_av = 1;
+ else {
+ SV **svp = AvARRAY(av);
+ assert(svp || max == 0);
+ for (i = 0; i < max; i++)
+ *SP++ = *svp++;
}
+ SP--;
+ p1 = p2 = SP - (max-1);
}
else {
p2 = MARK+1;
/* shuffle stack down, removing optional initial cv (p1!=p2), plus
* any nulls; also stringify or converting to integer or number as
* required any args */
- copytmps = !sorting_av && PL_sortcop;
+ copytmps = cBOOL(PL_sortcop);
for (i=max; i > 0 ; i--) {
if ((*p1 = *p2++)) { /* Weed out nulls. */
if (copytmps && SvPADTMP(*p1)) {
else
max--;
}
- if (sorting_av)
- AvFILLp(av) = max-1;
-
if (max > 1) {
SV **start;
if (PL_sortcop) {
}
else {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- start = sorting_av ? AvARRAY(av) : ORIGMARK+1;
+ start = ORIGMARK+1;
sortsvp(aTHX_ start, max,
(priv & OPpSORT_NUMERIC)
? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
}
}
}
- if (sorting_av)
- SvREADONLY_off(av);
- else if (av && !sorting_av) {
- /* simulate pp_aassign of tied AV */
- SV** const base = MARK+1;
- for (i=0; i < max; i++) {
- base[i] = newSVsv(base[i]);
- }
- av_clear(av);
- av_extend(av, max);
- for (i=0; i < max; i++) {
- SV * const sv = base[i];
- SV ** const didstore = av_store(av, i, sv);
- if (SvSMAGICAL(sv))
- mg_set(sv);
- if (!didstore)
- sv_2mortal(sv);
- }
+
+ if (av) {
+ /* copy back result to the array */
+ SV** const base = MARK+1;
+ if (SvMAGICAL(av)) {
+ for (i = 0; i < max; i++)
+ base[i] = newSVsv(base[i]);
+ av_clear(av);
+ av_extend(av, max);
+ for (i=0; i < max; i++) {
+ SV * const sv = base[i];
+ SV ** const didstore = av_store(av, i, sv);
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
+ if (!didstore)
+ sv_2mortal(sv);
+ }
+ }
+ else {
+ /* the elements of av are likely to be the same as the
+ * (non-refcounted) elements on the stack, just in a different
+ * order. However, its possible that someone's messed with av
+ * in the meantime. So bump and unbump the relevant refcounts
+ * first.
+ */
+ for (i = 0; i < max; i++) {
+ SV *sv = base[i];
+ assert(sv);
+ if (SvREFCNT(sv) > 1)
+ base[i] = newSVsv(sv);
+ else
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
+ av_clear(av);
+ if (max > 0) {
+ av_extend(av, max);
+ Copy(base, AvARRAY(av), max, SV*);
+ }
+ AvFILLp(av) = max - 1;
+ AvREIFY_off(av);
+ AvREAL_on(av);
+ }
}
LEAVE;
- PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max);
+ PL_stack_sp = ORIGMARK + max;
return nextop;
}
{
SV *target;
- PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
-
- if (*array) {
+ if (array && *array) {
target = newSVpvs_flags("", SVs_TEMP);
while (1) {
sv_catpv(target, *array);
PERL_CALLCONV const char * Perl_PerlIO_context_layers(pTHX_ const char *mode);
PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op);
#define PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS \
assert(p); assert(ustrp)
PERL_CALLCONV void Perl__warn_problematic_locale(void);
+PERL_CALLCONV LOGOP* Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP *other);
PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags);
#define PERL_ARGS_ASSERT_ALLOCMY \
assert(name)
__attribute__noreturn__
__attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
+PERL_CALLCONV_NO_RET void Perl_croak_caller(const char* pat, ...)
+ __attribute__noreturn__
+ __attribute__format__null_ok__(__printf__,1,2);
+
PERL_STATIC_NO_RET void S_croak_memory_wrap(void)
__attribute__noreturn__;
assert(buffer); assert(format)
PERL_CALLCONV OP* Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block);
PERL_CALLCONV OP* Perl_newANONHASH(pTHX_ OP* o)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newANONLIST(pTHX_ OP* o)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newANONSUB(pTHX_ I32 floor, OP* proto, OP* block);
PERL_CALLCONV OP* Perl_newASSIGNOP(pTHX_ I32 flags, OP* left, I32 optype, OP* right)
- __attribute__malloc__
__attribute__warn_unused_result__;
/* PERL_CALLCONV CV* newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block); */
#endif
PERL_CALLCONV OP* Perl_newAVREF(pTHX_ OP* o)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWAVREF \
assert(o)
PERL_CALLCONV OP* Perl_newBINOP(pTHX_ I32 type, I32 flags, OP* first, OP* last)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newCONDOP(pTHX_ I32 flags, OP* first, OP* trueop, OP* falseop)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWCONDOP \
assert(first)
PERL_CALLCONV CV* Perl_newCONSTSUB(pTHX_ HV* stash, const char* name, SV* sv);
PERL_CALLCONV CV* Perl_newCONSTSUB_flags(pTHX_ HV* stash, const char* name, STRLEN len, U32 flags, SV* sv);
PERL_CALLCONV OP* Perl_newCVREF(pTHX_ I32 flags, OP* o)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newDEFSVOP(pTHX)
PERL_CALLCONV void Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block);
PERL_CALLCONV OP* Perl_newFOROP(pTHX_ I32 flags, OP* sv, OP* expr, OP* block, OP* cont)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWFOROP \
assert(expr)
PERL_CALLCONV OP* Perl_newGIVENOP(pTHX_ OP* cond, OP* block, PADOFFSET defsv_off)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWGIVENOP \
assert(cond); assert(block)
#define PERL_ARGS_ASSERT_NEWGP \
assert(gv)
PERL_CALLCONV OP* Perl_newGVOP(pTHX_ I32 type, I32 flags, GV* gv)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWGVOP \
assert(gv)
PERL_CALLCONV OP* Perl_newGVREF(pTHX_ I32 type, OP* o)
- __attribute__malloc__
__attribute__warn_unused_result__;
/* PERL_CALLCONV GV* newGVgen(pTHX_ const char* pack); */
PERL_CALLCONV GV* Perl_newGVgen_flags(pTHX_ const char* pack, U32 flags)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWGVGEN_FLAGS \
assert(pack)
#endif
PERL_CALLCONV OP* Perl_newHVREF(pTHX_ OP* o)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWHVREF \
assert(o)
PERL_CALLCONV HV* Perl_newHVhv(pTHX_ HV *hv)
- __attribute__malloc__
__attribute__warn_unused_result__;
#ifndef NO_MATHOMS
PERL_CALLCONV IO* Perl_newIO(pTHX)
- __attribute__malloc__
__attribute__warn_unused_result__;
#endif
PERL_CALLCONV OP* Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP* first, OP* last)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newLOGOP(pTHX_ I32 optype, I32 flags, OP *first, OP *other)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWLOGOP \
assert(first); assert(other)
PERL_CALLCONV OP* Perl_newLOOPEX(pTHX_ I32 type, OP* label)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWLOOPEX \
assert(label)
PERL_CALLCONV OP* Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP* expr, OP* block)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newMETHOP(pTHX_ I32 type, I32 flags, OP* dynamic_meth)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWMETHOP \
assert(dynamic_meth)
PERL_CALLCONV OP* Perl_newMETHOP_named(pTHX_ I32 type, I32 flags, SV* const_meth)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWMETHOP_NAMED \
assert(const_meth)
#define PERL_ARGS_ASSERT_NEWMYSUB \
assert(o)
PERL_CALLCONV OP* Perl_newNULLLIST(pTHX)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newOP(pTHX_ I32 optype, I32 flags)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV PADNAMELIST * Perl_newPADNAMELIST(size_t max)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV PADNAME * Perl_newPADNAMEouter(PADNAME *outer)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWPADNAMEOUTER \
assert(outer)
PERL_CALLCONV PADNAME * Perl_newPADNAMEpvn(const char *s, STRLEN len)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWPADNAMEPVN \
assert(s)
PERL_CALLCONV OP* Perl_newPMOP(pTHX_ I32 type, I32 flags)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV void Perl_newPROG(pTHX_ OP* o);
#define PERL_ARGS_ASSERT_NEWPROG \
assert(o)
PERL_CALLCONV OP* Perl_newPVOP(pTHX_ I32 type, I32 flags, char* pv)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newRANGE(pTHX_ I32 flags, OP* left, OP* right)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWRANGE \
assert(left); assert(right)
PERL_CALLCONV SV* Perl_newRV(pTHX_ SV *const sv)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWRV \
assert(sv)
PERL_CALLCONV SV* Perl_newRV_noinc(pTHX_ SV *const tmpRef)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWRV_NOINC \
assert(tmpRef)
PERL_CALLCONV OP* Perl_newSLICEOP(pTHX_ I32 flags, OP* subscript, OP* listop)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newSTATEOP(pTHX_ I32 flags, char* label, OP* o)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV CV* Perl_newSTUB(pTHX_ GV *gv, bool fake);
PERL_CALLCONV CV* Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block);
#endif
PERL_CALLCONV SV* Perl_newSV(pTHX_ const STRLEN len)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newSVOP(pTHX_ I32 type, I32 flags, SV* sv)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWSVOP \
assert(sv)
PERL_CALLCONV OP* Perl_newSVREF(pTHX_ OP* o)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWSVREF \
assert(o)
PERL_CALLCONV SV* Perl_newSV_type(pTHX_ const svtype type)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWSVAVDEFELEM \
assert(av)
PERL_CALLCONV SV* Perl_newSVhek(pTHX_ const HEK *const hek)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSViv(pTHX_ const IV i)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVnv(pTHX_ const NV n)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVpv_share(pTHX_ const char* s, U32 hash)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVpvf(pTHX_ const char *const pat, ...)
- __attribute__malloc__
__attribute__warn_unused_result__
__attribute__format__(__printf__,pTHX_1,pTHX_2);
#define PERL_ARGS_ASSERT_NEWSVPVF \
assert(pat)
PERL_CALLCONV SV* Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVpvn_share(pTHX_ const char* s, I32 len, U32 hash)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVrv(pTHX_ SV *const rv, const char *const classname);
#define PERL_ARGS_ASSERT_NEWSVRV \
assert(rv)
PERL_CALLCONV SV* Perl_newSVsv(pTHX_ SV *const old)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_newSVuv(pTHX_ const UV u)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newUNOP(pTHX_ I32 type, I32 flags, OP* first)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP* first, UNOP_AUX_item *aux)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV OP* Perl_newWHENOP(pTHX_ OP* cond, OP* block)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWWHENOP \
assert(block)
PERL_CALLCONV OP* Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP* loop, OP* expr, OP* block, OP* cont, I32 has_my)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV CV* Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename);
assert(newctype)
PERL_CALLCONV void Perl_new_numeric(pTHX_ const char* newcoll);
PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver);
#define PERL_ARGS_ASSERT_NEW_VERSION \
assert(ver)
PERL_CALLCONV STRLEN * Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, STRLEN size)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD \
assert(bits)
PERL_CALLCONV void Perl_pad_free(pTHX_ PADOFFSET po);
PERL_CALLCONV OP * Perl_pad_leavemy(pTHX);
PERL_CALLCONV PADLIST* Perl_pad_new(pTHX_ int flags)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV void Perl_pad_push(pTHX_ PADLIST *padlist, int depth);
PERL_CALLCONV SV* Perl_parse_label(pTHX_ U32 flags);
PERL_CALLCONV OP* Perl_parse_listexpr(pTHX_ U32 flags);
PERL_CALLCONV OP* Perl_parse_stmtseq(pTHX_ U32 flags);
-PERL_CALLCONV OP * Perl_parse_subsignature(pTHX)
- __attribute__warn_unused_result__;
-
PERL_CALLCONV OP* Perl_parse_termexpr(pTHX_ U32 flags);
PERL_CALLCONV U32 Perl_parse_unicode_opts(pTHX_ const char **popt);
#define PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS \
PERL_CALLCONV void Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl);
PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl);
#define PERL_ARGS_ASSERT_RE_OP_COMPILE \
assert(eng)
PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV void Perl_reentrant_free(pTHX);
__attribute__warn_unused_result__;
PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV void Perl_save_I16(pTHX_ I16* intp);
assert(sv)
#ifndef NO_MATHOMS
PERL_CALLCONV SV* Perl_sv_mortalcopy(pTHX_ SV *const oldsv)
- __attribute__malloc__
__attribute__warn_unused_result__;
#endif
PERL_CALLCONV SV* Perl_sv_mortalcopy_flags(pTHX_ SV *const oldsv, U32 flags)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_sv_newmortal(pTHX)
#define PERL_ARGS_ASSERT_VMESS \
assert(pat)
PERL_CALLCONV SV* Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_VNEWSVPVF \
assert(pat)
STATIC void S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end);
#define PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST \
assert(invlist)
+PERL_STATIC_INLINE UV* S__invlist_array_init(SV* const invlist, const bool will_have_0)
+ __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT \
+ assert(invlist)
+
PERL_STATIC_INLINE IV* S_get_invlist_previous_index_addr(SV* invlist)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR \
STATIC void S_invlist_extend(pTHX_ SV* const invlist, const UV len);
#define PERL_ARGS_ASSERT_INVLIST_EXTEND \
assert(invlist)
+PERL_STATIC_INLINE UV S_invlist_max(SV* const invlist)
+ __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_INVLIST_MAX \
+ assert(invlist)
+
PERL_STATIC_INLINE IV S_invlist_previous_index(SV* const invlist)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX \
__attribute__pure__;
# endif
+# if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
+STATIC void S_print_collxfrm_input_and_return(pTHX_ const char * const s, const char * const e, const STRLEN * const xlen, const bool is_utf8);
+#define PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN \
+ assert(s); assert(e)
+# endif
#endif
#if defined(DEBUG_LEAKING_SCALARS_FORK_DUMP)
PERL_CALLCONV void Perl_dump_sv_child(pTHX_ SV *sv);
STATIC bool S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8);
#define PERL_ARGS_ASSERT_GV_IS_IN_MAIN \
assert(name)
-STATIC bool S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, bool addmg, const svtype sv_type);
+STATIC bool S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, const svtype sv_type);
#define PERL_ARGS_ASSERT_GV_MAGICALIZE \
assert(gv); assert(stash); assert(name)
STATIC void S_gv_magicalize_isa(pTHX_ GV *gv);
STATIC bool S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, STRLEN *len, const char *nambeg, STRLEN full_len, const U32 is_utf8, const I32 add);
#define PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME \
assert(stash); assert(gv); assert(name); assert(len); assert(nambeg)
-STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv, const U32 flags);
+STATIC void S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, STRLEN len, const U32 flags);
#define PERL_ARGS_ASSERT_REQUIRE_TIE_MOD \
- assert(gv); assert(varpv); assert(namesv); assert(methpv)
+ assert(gv); assert(varname); assert(name)
#endif
#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
PERL_CALLCONV void Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv);
assert(key); assert(msg)
STATIC HE* S_new_he(pTHX)
- __attribute__malloc__
__attribute__warn_unused_result__;
PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u);
#define PERL_ARGS_ASSERT_DOFORM \
assert(cv); assert(gv)
STATIC SV * S_space_join_names_mortal(pTHX_ char *const *array);
-#define PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL \
- assert(array)
#endif
#if defined(PERL_IN_REGCOMP_C)
-PERL_STATIC_INLINE UV* S__invlist_array_init(SV* const invlist, const bool will_have_0)
- __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT \
- assert(invlist)
-
STATIC SV* S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST \
#define PERL_ARGS_ASSERT_INVLIST_ITERNEXT \
assert(invlist); assert(start); assert(end)
-PERL_STATIC_INLINE UV S_invlist_max(SV* const invlist)
- __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT_INVLIST_MAX \
- assert(invlist)
-
PERL_STATIC_INLINE void S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset);
#define PERL_ARGS_ASSERT_INVLIST_SET_LEN \
assert(invlist)
#define PERL_ARGS_ASSERT_CLONE_PARAMS_DEL \
assert(param)
PERL_CALLCONV CLONE_PARAMS * Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_CLONE_PARAMS_NEW \
assert(from); assert(to)
#define PERL_ARGS_ASSERT_MRO_META_DUP \
assert(smeta); assert(param)
PERL_CALLCONV OP* Perl_newPADOP(pTHX_ I32 type, I32 flags, SV* sv)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWPADOP \
assert(sv)
assert(param)
PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl, CLONE_PARAMS* param)
- __attribute__malloc__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SS_DUP \
assert(proto_perl); assert(param)
* 37f6186253da9824bdb27f4ad867bfe8c25d4dc6bdb2f05585e40a034675a348 lib/unicore/extracted/DLineBreak.txt
* ef24061b5a5dc93d7e90c2e34530ec757180ee75d872cba65ffc946e52624ae8 lib/unicore/extracted/DNumType.txt
* a197371fec9a1b517058b440841f60f9378d81682084eef8db22a88cb2f96e90 lib/unicore/extracted/DNumValues.txt
- * 0cc006e22469cee3db1a55a4df1ac656c9d26a70ba920985883eb77198931c1a lib/unicore/mktables
+ * 5c7eb94310e2aaa15702fd6bed24ff0e7ab5448f9a8231d8c49ca96c9e941089 lib/unicore/mktables
* cdecb300baad839a6f62791229f551a4fa33f3cbdca08e378dc976466354e778 lib/unicore/version
* 913d2f93f3cb6cdf1664db888bf840bc4eb074eef824e082fceda24a9445e60c regen/charset_translations.pl
* d9c04ac46bdd81bb3e26519f2b8eb6242cb12337205add3f7cf092b0c58dccc4 regen/regcharclass.pl
/* The header definitions are in F<invlist_inline.h> */
+#ifndef PERL_IN_XSUB_RE
+
PERL_STATIC_INLINE UV*
S__invlist_array_init(SV* const invlist, const bool will_have_0)
{
return zero_addr + *offset;
}
+#endif
+
PERL_STATIC_INLINE void
S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
{
return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
}
+#ifndef PERL_IN_XSUB_RE
+
PERL_STATIC_INLINE UV
S_invlist_max(SV* const invlist)
{
? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
: FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
}
-
-#ifndef PERL_IN_XSUB_RE
SV*
Perl__new_invlist(pTHX_ IV initial_size)
{
&nonascii_but_latin1_properties);
/* And add them to the final list of such characters. */
- if (has_upper_latin1_only_utf8_matches) {
- _invlist_union(has_upper_latin1_only_utf8_matches,
- nonascii_but_latin1_properties,
- &has_upper_latin1_only_utf8_matches);
- SvREFCNT_dec_NN(nonascii_but_latin1_properties);
- }
- else {
- has_upper_latin1_only_utf8_matches
- = nonascii_but_latin1_properties;
- }
+ _invlist_union(has_upper_latin1_only_utf8_matches,
+ nonascii_but_latin1_properties,
+ &has_upper_latin1_only_utf8_matches);
/* Remove them from what now becomes the unconditional list */
_invlist_subtract(posixes, nonascii_but_latin1_properties,
&posixes);
- /* And the remainder are the unconditional ones */
+ /* And add those unconditional ones to the final list */
if (cp_list) {
_invlist_union(cp_list, posixes, &cp_list);
SvREFCNT_dec_NN(posixes);
cp_list = posixes;
}
+ SvREFCNT_dec(nonascii_but_latin1_properties);
+
/* Get rid of any characters that we now know are matched
- * unconditionally from the conditional list */
+ * unconditionally from the conditional list, which may make
+ * that list empty */
_invlist_subtract(has_upper_latin1_only_utf8_matches,
cp_list,
&has_upper_latin1_only_utf8_matches);
addbits('avhvswitch', '0..1' => { });
+addbits('argelem',
+ '1..2' => {
+ mask_def => 'OPpARGELEM_MASK',
+ enum => [ qw(
+ 0 OPpARGELEM_SV SV
+ 1 OPpARGELEM_AV AV
+ 2 OPpARGELEM_HV HV
+ )],
+ },
+);
+
+
1;
# ex: set ts=8 sts=4 sw=4 et:
entersub subroutine entry ck_subr dm1 L
leavesub subroutine exit ck_null 1
leavesublv lvalue subroutine return ck_null 1
+argcheck check subroutine arguments ck_null +
+argelem subroutine argument ck_null +
+argdefelem subroutine argument default value ck_null |
caller caller ck_fun t% S?
warn warn ck_fun imst@ L
die die ck_fun imst@ L
case _CC_ENUM_ALPHA: return isALPHA_LC(character);
case _CC_ENUM_ASCII: return isASCII_LC(character);
case _CC_ENUM_BLANK: return isBLANK_LC(character);
- case _CC_ENUM_CASED: return isLOWER_LC(character)
+ case _CC_ENUM_CASED: return isLOWER_LC(character)
|| isUPPER_LC(character);
case _CC_ENUM_CNTRL: return isCNTRL_LC(character);
case _CC_ENUM_DIGIT: return isDIGIT_LC(character);
SS_ADD_END(3);
}
+void
+Perl_save_iv(pTHX_ IV *ivp)
+{
+ PERL_ARGS_ASSERT_SAVE_IV;
+
+ SSCHECK(3);
+ SSPUSHIV(*ivp);
+ SSPUSHPTR(ivp);
+ SSPUSHUV(SAVEt_IV);
+}
+
/* Cannot use save_sptr() to store a char* since the SV** cast will
* force word-alignment and we'll miss the pointer.
*/
}
+static U8 arg_counts[] = {
+ 0, /* SAVEt_ALLOC */
+ 0, /* SAVEt_CLEARPADRANGE */
+ 0, /* SAVEt_CLEARSV */
+ 0, /* SAVEt_REGCONTEXT */
+ 1, /* SAVEt_TMPSFLOOR */
+ 1, /* SAVEt_BOOL */
+ 1, /* SAVEt_COMPILE_WARNINGS */
+ 1, /* SAVEt_COMPPAD */
+ 1, /* SAVEt_FREECOPHH */
+ 1, /* SAVEt_FREEOP */
+ 1, /* SAVEt_FREEPV */
+ 1, /* SAVEt_FREESV */
+ 1, /* SAVEt_I16 */
+ 1, /* SAVEt_I32_SMALL */
+ 1, /* SAVEt_I8 */
+ 1, /* SAVEt_INT_SMALL */
+ 1, /* SAVEt_MORTALIZESV */
+ 1, /* SAVEt_NSTAB */
+ 1, /* SAVEt_OP */
+ 1, /* SAVEt_PARSER */
+ 1, /* SAVEt_STACK_POS */
+ 1, /* SAVEt_READONLY_OFF */
+ 1, /* SAVEt_FREEPADNAME */
+ 2, /* SAVEt_AV */
+ 2, /* SAVEt_DESTRUCTOR */
+ 2, /* SAVEt_DESTRUCTOR_X */
+ 2, /* SAVEt_GENERIC_PVREF */
+ 2, /* SAVEt_GENERIC_SVREF */
+ 2, /* SAVEt_GP */
+ 2, /* SAVEt_GVSV */
+ 2, /* SAVEt_HINTS */
+ 2, /* SAVEt_HPTR */
+ 2, /* SAVEt_HV */
+ 2, /* SAVEt_I32 */
+ 2, /* SAVEt_INT */
+ 2, /* SAVEt_ITEM */
+ 2, /* SAVEt_IV */
+ 2, /* SAVEt_LONG */
+ 2, /* SAVEt_PPTR */
+ 2, /* SAVEt_SAVESWITCHSTACK */
+ 2, /* SAVEt_SHARED_PVREF */
+ 2, /* SAVEt_SPTR */
+ 2, /* SAVEt_STRLEN */
+ 2, /* SAVEt_SV */
+ 2, /* SAVEt_SVREF */
+ 2, /* SAVEt_VPTR */
+ 2, /* SAVEt_ADELETE */
+ 2, /* SAVEt_APTR */
+ 3, /* SAVEt_HELEM */
+ 3, /* SAVEt_PADSV_AND_MORTALIZE*/
+ 3, /* SAVEt_SET_SVFLAGS */
+ 3, /* SAVEt_GVSLOT */
+ 3, /* SAVEt_AELEM */
+ 3 /* SAVEt_DELETE */
+};
-#define ARG0_SV MUTABLE_SV(arg0.any_ptr)
-#define ARG0_AV MUTABLE_AV(arg0.any_ptr)
-#define ARG0_HV MUTABLE_HV(arg0.any_ptr)
-#define ARG0_PTR arg0.any_ptr
-#define ARG0_PV (char*)(arg0.any_ptr)
-#define ARG0_PVP (char**)(arg0.any_ptr)
-#define ARG0_I32 (arg0.any_i32)
-
-#define ARG1_SV MUTABLE_SV(arg1.any_ptr)
-#define ARG1_AV MUTABLE_AV(arg1.any_ptr)
-#define ARG1_GV MUTABLE_GV(arg1.any_ptr)
-#define ARG1_SVP (SV**)(arg1.any_ptr)
-#define ARG1_PVP (char**)(arg1.any_ptr)
-#define ARG1_PTR arg1.any_ptr
-#define ARG1_PV (char*)(arg1.any_ptr)
-#define ARG1_I32 (arg1.any_i32)
-
-#define ARG2_SV MUTABLE_SV(arg2.any_ptr)
-#define ARG2_AV MUTABLE_AV(arg2.any_ptr)
-#define ARG2_HV MUTABLE_HV(arg2.any_ptr)
-#define ARG2_GV MUTABLE_GV(arg2.any_ptr)
-#define ARG2_PV (char*)(arg2.any_ptr)
void
Perl_leave_scope(pTHX_ I32 base)
/* Localise the effects of the TAINT_NOT inside the loop. */
bool was = TAINT_get;
- I32 i;
- SV *sv;
-
- ANY arg0, arg1, arg2;
-
- /* these initialisations are logically unnecessary, but they shut up
- * spurious 'may be used uninitialized' compiler warnings */
- arg0.any_ptr = NULL;
- arg1.any_ptr = NULL;
- arg2.any_ptr = NULL;
-
if (UNLIKELY(base < -1))
Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
while (PL_savestack_ix > base) {
UV uv;
U8 type;
-
- SV *refsv;
- SV **svp;
+ ANY *ap; /* arg pointer */
+ ANY a0, a1, a2; /* up to 3 args */
TAINT_NOT;
{
+ U8 argcount;
I32 ix = PL_savestack_ix - 1;
- ANY *p = &PL_savestack[ix];
- uv = p->any_uv;
+
+ ap = &PL_savestack[ix];
+ uv = ap->any_uv;
type = (U8)uv & SAVE_MASK;
- if (type > SAVEt_ARG0_MAX) {
- ANY *p0 = p;
- arg0 = *--p;
- if (type > SAVEt_ARG1_MAX) {
- arg1 = *--p;
- if (type > SAVEt_ARG2_MAX) {
- arg2 = *--p;
- }
- }
- ix -= (p0 - p);
- }
- PL_savestack_ix = ix;
+ argcount = arg_counts[type];
+ PL_savestack_ix = ix - argcount;
+ ap -= argcount;
}
switch (type) {
case SAVEt_ITEM: /* normal string */
- sv_replace(ARG1_SV, ARG0_SV);
- if (UNLIKELY(SvSMAGICAL(ARG1_SV))) {
+ a0 = ap[0]; a1 = ap[1];
+ sv_replace(a0.any_sv, a1.any_sv);
+ if (UNLIKELY(SvSMAGICAL(a0.any_sv))) {
PL_localizing = 2;
- mg_set(ARG1_SV);
+ mg_set(a0.any_sv);
PL_localizing = 0;
}
break;
/* This would be a mathom, but Perl_save_svref() calls a static
function, S_save_scalar_at(), so has to stay in this file. */
case SAVEt_SVREF: /* scalar reference */
- svp = ARG1_SVP;
- refsv = NULL; /* what to refcnt_dec */
+ a0 = ap[0]; a1 = ap[1];
+ a2.any_svp = a0.any_svp;
+ a0.any_sv = NULL; /* what to refcnt_dec */
goto restore_sv;
case SAVEt_SV: /* scalar reference */
- svp = &GvSV(ARG1_GV);
- refsv = ARG1_SV; /* what to refcnt_dec */
+ a0 = ap[0]; a1 = ap[1];
+ a2.any_svp = &GvSV(a0.any_gv);
restore_sv:
{
- SV * const sv = *svp;
- *svp = ARG0_SV;
+ /* do *a2.any_svp = a1 and free a0 */
+ SV * const sv = *a2.any_svp;
+ *a2.any_svp = a1.any_sv;
SvREFCNT_dec(sv);
- if (UNLIKELY(SvSMAGICAL(ARG0_SV))) {
- /* mg_set could die, skipping the freeing of ARG0_SV and
- * refsv; Ensure that they're always freed in that case */
+ if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
+ /* mg_set could die, skipping the freeing of a0 and
+ * a1; Ensure that they're always freed in that case */
dSS_ADD;
- SS_ADD_PTR(ARG0_SV);
+ SS_ADD_PTR(a1.any_sv);
SS_ADD_UV(SAVEt_FREESV);
- SS_ADD_PTR(refsv);
+ SS_ADD_PTR(a0.any_sv);
SS_ADD_UV(SAVEt_FREESV);
SS_ADD_END(4);
PL_localizing = 2;
- mg_set(ARG0_SV);
+ mg_set(a1.any_sv);
PL_localizing = 0;
break;
}
- SvREFCNT_dec_NN(ARG0_SV);
- SvREFCNT_dec(refsv);
+ SvREFCNT_dec_NN(a1.any_sv);
+ SvREFCNT_dec(a0.any_sv);
break;
}
+
case SAVEt_GENERIC_PVREF: /* generic pv */
- if (*ARG0_PVP != ARG1_PV) {
- Safefree(*ARG0_PVP);
- *ARG0_PVP = ARG1_PV;
+ a0 = ap[0]; a1 = ap[1];
+ if (*a1.any_pvp != a0.any_pv) {
+ Safefree(*a1.any_pvp);
+ *a1.any_pvp = a0.any_pv;
}
break;
+
case SAVEt_SHARED_PVREF: /* shared pv */
- if (*ARG1_PVP != ARG0_PV) {
+ a0 = ap[0]; a1 = ap[1];
+ if (*a0.any_pvp != a1.any_pv) {
#ifdef NETWARE
- PerlMem_free(*ARG1_PVP);
+ PerlMem_free(*a0.any_pvp);
#else
- PerlMemShared_free(*ARG1_PVP);
+ PerlMemShared_free(*a0.any_pvp);
#endif
- *ARG1_PVP = ARG0_PV;
+ *a0.any_pvp = a1.any_pv;
}
break;
+
case SAVEt_GVSV: /* scalar slot in GV */
- svp = &GvSV(ARG1_GV);
+ a0 = ap[0]; a1 = ap[1];
+ a0.any_svp = &GvSV(a0.any_gv);
goto restore_svp;
+
case SAVEt_GENERIC_SVREF: /* generic sv */
- svp = ARG1_SVP;
+ a0 = ap[0]; a1 = ap[1];
restore_svp:
{
- SV * const sv = *svp;
- *svp = ARG0_SV;
+ /* do *a0.any_svp = a1 */
+ SV * const sv = *a0.any_svp;
+ *a0.any_svp = a1.any_sv;
SvREFCNT_dec(sv);
- SvREFCNT_dec(ARG0_SV);
+ SvREFCNT_dec(a1.any_sv);
break;
}
+
case SAVEt_GVSLOT: /* any slot in GV */
{
- HV *const hv = GvSTASH(ARG2_GV);
- svp = ARG1_SVP;
+ HV * hv;
+ a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
+ hv = GvSTASH(a0.any_gv);
if (hv && HvENAME(hv) && (
- (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV)
- || (*svp && SvTYPE(*svp) == SVt_PVCV)
+ (a2.any_sv && SvTYPE(a2.any_sv) == SVt_PVCV)
+ || (*a1.any_svp && SvTYPE(*a1.any_svp) == SVt_PVCV)
))
{
- if ((char *)svp < (char *)GvGP(ARG2_GV)
- || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp)
- || GvREFCNT(ARG2_GV) > 2) /* "> 2" to ignore savestack's ref */
+ if ((char *)a1.any_svp < (char *)GvGP(a0.any_gv)
+ || (char *)a1.any_svp > (char *)GvGP(a0.any_gv) + sizeof(struct gp)
+ || GvREFCNT(a0.any_gv) > 2) /* "> 2" to ignore savestack's ref */
PL_sub_generation++;
else mro_method_changed_in(hv);
}
+ a0.any_svp = a1.any_svp;
+ a1.any_sv = a2.any_sv;
goto restore_svp;
}
+
case SAVEt_AV: /* array reference */
- SvREFCNT_dec(GvAV(ARG1_GV));
- GvAV(ARG1_GV) = ARG0_AV;
+ a0 = ap[0]; a1 = ap[1];
+ SvREFCNT_dec(GvAV(a0.any_gv));
+ GvAV(a0.any_gv) = a1.any_av;
avhv_common:
- if (UNLIKELY(SvSMAGICAL(ARG0_SV))) {
- /* mg_set might die, so make sure ARG1 isn't leaked */
+ if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
+ /* mg_set might die, so make sure a0 isn't leaked */
dSS_ADD;
- SS_ADD_PTR(ARG1_SV);
+ SS_ADD_PTR(a0.any_sv);
SS_ADD_UV(SAVEt_FREESV);
SS_ADD_END(2);
PL_localizing = 2;
- mg_set(ARG0_SV);
+ mg_set(a1.any_sv);
PL_localizing = 0;
break;
}
- SvREFCNT_dec_NN(ARG1_GV);
+ SvREFCNT_dec_NN(a0.any_sv);
break;
+
case SAVEt_HV: /* hash reference */
- SvREFCNT_dec(GvHV(ARG1_GV));
- GvHV(ARG1_GV) = ARG0_HV;
+ a0 = ap[0]; a1 = ap[1];
+ SvREFCNT_dec(GvHV(a0.any_gv));
+ GvHV(a0.any_gv) = a1.any_hv;
goto avhv_common;
case SAVEt_INT_SMALL:
- *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT);
+ a0 = ap[0];
+ *(int*)a0.any_ptr = (int)(uv >> SAVE_TIGHT_SHIFT);
break;
+
case SAVEt_INT: /* int reference */
- *(int*)ARG0_PTR = (int)ARG1_I32;
+ a0 = ap[0]; a1 = ap[1];
+ *(int*)a1.any_ptr = (int)a0.any_i32;
break;
+
case SAVEt_STRLEN: /* STRLEN/size_t ref */
- *(STRLEN*)ARG0_PTR = (STRLEN)arg1.any_iv;
+ a0 = ap[0]; a1 = ap[1];
+ *(STRLEN*)a1.any_ptr = (STRLEN)a0.any_iv;
break;
+
case SAVEt_TMPSFLOOR: /* restore PL_tmps_floor */
- PL_tmps_floor = (SSize_t)arg0.any_iv;
+ a0 = ap[0];
+ PL_tmps_floor = (SSize_t)a0.any_iv;
break;
+
case SAVEt_BOOL: /* bool reference */
- *(bool*)ARG0_PTR = cBOOL(uv >> 8);
+ a0 = ap[0];
+ *(bool*)a0.any_ptr = cBOOL(uv >> 8);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was);
#else
- if (UNLIKELY(ARG0_PTR == &(TAINT_get))) {
+ if (UNLIKELY(a0.any_ptr == &(TAINT_get))) {
/* If we don't update <was>, to reflect what was saved on the
* stack for PL_tainted, then we will overwrite this attempt to
* restore it when we exit this routine. Note that this won't
* work if this value was saved in a wider-than necessary type,
* such as I32 */
- was = *(bool*)ARG0_PTR;
+ was = *(bool*)a0.any_ptr;
}
#endif
break;
+
case SAVEt_I32_SMALL:
- *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT);
+ a0 = ap[0];
+ *(I32*)a0.any_ptr = (I32)(uv >> SAVE_TIGHT_SHIFT);
break;
+
case SAVEt_I32: /* I32 reference */
+ a0 = ap[0]; a1 = ap[1];
#ifdef PERL_DEBUG_READONLY_OPS
- if (*(I32*)ARG0_PTR != ARG1_I32)
+ if (*(I32*)a1.any_ptr != a0.any_i32)
#endif
- *(I32*)ARG0_PTR = ARG1_I32;
+ *(I32*)a1.any_ptr = a0.any_i32;
break;
+
case SAVEt_SPTR: /* SV* reference */
- *(SV**)(ARG0_PTR)= ARG1_SV;
- break;
case SAVEt_VPTR: /* random* reference */
case SAVEt_PPTR: /* char* reference */
- *ARG0_PVP = ARG1_PV;
- break;
case SAVEt_HPTR: /* HV* reference */
- *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR);
- break;
case SAVEt_APTR: /* AV* reference */
- *(AV**)ARG0_PTR = ARG1_AV;
+ a0 = ap[0]; a1 = ap[1];
+ *a1.any_svp= a0.any_sv;
break;
+
case SAVEt_GP: /* scalar reference */
{
HV *hv;
+ bool had_method;
+
+ a0 = ap[0]; a1 = ap[1];
/* possibly taking a method out of circulation */
- const bool had_method = !!GvCVu(ARG1_GV);
- gp_free(ARG1_GV);
- GvGP_set(ARG1_GV, (GP*)ARG0_PTR);
- if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) {
- if ( GvNAMELEN(ARG1_GV) == 3
- && strnEQ(GvNAME(ARG1_GV), "ISA", 3)
+ had_method = !!GvCVu(a0.any_gv);
+ gp_free(a0.any_gv);
+ GvGP_set(a0.any_gv, (GP*)a1.any_ptr);
+ if ((hv=GvSTASH(a0.any_gv)) && HvENAME_get(hv)) {
+ if ( GvNAMELEN(a0.any_gv) == 3
+ && strnEQ(GvNAME(a0.any_gv), "ISA", 3)
)
mro_isa_changed_in(hv);
- else if (had_method || GvCVu(ARG1_GV))
+ else if (had_method || GvCVu(a0.any_gv))
/* putting a method back into circulation ("local")*/
- gv_method_changed(ARG1_GV);
+ gv_method_changed(a0.any_gv);
}
- SvREFCNT_dec_NN(ARG1_GV);
+ SvREFCNT_dec_NN(a0.any_gv);
break;
}
+
case SAVEt_FREESV:
- SvREFCNT_dec(ARG0_SV);
+ a0 = ap[0];
+ SvREFCNT_dec(a0.any_sv);
break;
+
case SAVEt_FREEPADNAME:
- PadnameREFCNT_dec((PADNAME *)ARG0_PTR);
+ a0 = ap[0];
+ PadnameREFCNT_dec((PADNAME *)a0.any_ptr);
break;
+
case SAVEt_FREECOPHH:
- cophh_free((COPHH *)ARG0_PTR);
+ a0 = ap[0];
+ cophh_free((COPHH *)a0.any_ptr);
break;
+
case SAVEt_MORTALIZESV:
- sv_2mortal(ARG0_SV);
+ a0 = ap[0];
+ sv_2mortal(a0.any_sv);
break;
+
case SAVEt_FREEOP:
+ a0 = ap[0];
ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
- op_free((OP*)ARG0_PTR);
+ op_free(a0.any_op);
break;
+
case SAVEt_FREEPV:
- Safefree(ARG0_PTR);
+ a0 = ap[0];
+ Safefree(a0.any_ptr);
break;
case SAVEt_CLEARPADRANGE:
+ {
+ I32 i;
+ SV **svp;
i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
- svp = &PL_curpad[uv >>
+ svp = &PL_curpad[uv >>
(OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
goto clearsv;
case SAVEt_CLEARSV:
i = 1;
clearsv:
for (; i; i--, svp--) {
- sv = *svp;
+ SV *sv = *svp;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
}
}
break;
+ }
+
case SAVEt_DELETE:
- (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD);
- SvREFCNT_dec(ARG0_HV);
- Safefree(arg2.any_ptr);
+ a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
+ (void)hv_delete(a2.any_hv, a0.any_pv, a1.any_i32, G_DISCARD);
+ SvREFCNT_dec(a2.any_hv);
+ Safefree(a0.any_ptr);
break;
+
case SAVEt_ADELETE:
- (void)av_delete(ARG0_AV, arg1.any_iv, G_DISCARD);
- SvREFCNT_dec(ARG0_AV);
+ a0 = ap[0]; a1 = ap[1];
+ (void)av_delete(a1.any_av, a0.any_iv, G_DISCARD);
+ SvREFCNT_dec(a1.any_av);
break;
+
case SAVEt_DESTRUCTOR_X:
- (*arg1.any_dxptr)(aTHX_ ARG0_PTR);
+ a0 = ap[0]; a1 = ap[1];
+ (*a0.any_dxptr)(aTHX_ a1.any_ptr);
break;
+
case SAVEt_REGCONTEXT:
/* regexp must have croaked */
case SAVEt_ALLOC:
PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
break;
+
case SAVEt_STACK_POS: /* Position on Perl stack */
- PL_stack_sp = PL_stack_base + arg0.any_i32;
+ a0 = ap[0];
+ PL_stack_sp = PL_stack_base + a0.any_i32;
break;
+
case SAVEt_AELEM: /* array element */
- svp = av_fetch(ARG2_AV, arg1.any_iv, 1);
- if (UNLIKELY(!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV))) /* undo reify guard */
- SvREFCNT_dec(ARG0_SV);
+ {
+ SV **svp;
+ a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
+ svp = av_fetch(a0.any_av, a1.any_iv, 1);
+ if (UNLIKELY(!AvREAL(a0.any_av) && AvREIFY(a0.any_av))) /* undo reify guard */
+ SvREFCNT_dec(a2.any_sv);
if (LIKELY(svp)) {
SV * const sv = *svp;
if (LIKELY(sv && sv != &PL_sv_undef)) {
- if (UNLIKELY(SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied)))
+ if (UNLIKELY(SvTIED_mg((const SV *)a0.any_av, PERL_MAGIC_tied)))
SvREFCNT_inc_void_NN(sv);
- refsv = ARG2_SV;
+ a1.any_sv = a2.any_sv;
+ a2.any_svp = svp;
goto restore_sv;
}
}
- SvREFCNT_dec(ARG2_AV);
- SvREFCNT_dec(ARG0_SV);
+ SvREFCNT_dec(a0.any_av);
+ SvREFCNT_dec(a2.any_sv);
break;
+ }
+
case SAVEt_HELEM: /* hash element */
{
- HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0);
- SvREFCNT_dec(ARG1_SV);
+ HE *he;
+
+ a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
+ he = hv_fetch_ent(a0.any_hv, a1.any_sv, 1, 0);
+ SvREFCNT_dec(a1.any_sv);
if (LIKELY(he)) {
const SV * const oval = HeVAL(he);
if (LIKELY(oval && oval != &PL_sv_undef)) {
- svp = &HeVAL(he);
- if (UNLIKELY(SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied)))
+ SV **svp = &HeVAL(he);
+ if (UNLIKELY(SvTIED_mg((const SV *)a0.any_hv, PERL_MAGIC_tied)))
SvREFCNT_inc_void(*svp);
- refsv = ARG2_SV; /* what to refcnt_dec */
+ a1.any_sv = a2.any_sv;
+ a2.any_svp = svp;
goto restore_sv;
}
}
- SvREFCNT_dec(ARG2_HV);
- SvREFCNT_dec(ARG0_SV);
+ SvREFCNT_dec(a0.any_hv);
+ SvREFCNT_dec(a2.any_sv);
break;
}
+
case SAVEt_OP:
- PL_op = (OP*)ARG0_PTR;
+ a0 = ap[0];
+ PL_op = (OP*)a0.any_ptr;
break;
+
case SAVEt_HINTS:
+ a0 = ap[0]; a1 = ap[1];
if ((PL_hints & HINT_LOCALIZE_HH)) {
while (GvHV(PL_hintgv)) {
HV *hv = GvHV(PL_hintgv);
}
}
cophh_free(CopHINTHASH_get(&PL_compiling));
- CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR);
- *(I32*)&PL_hints = ARG1_I32;
+ CopHINTHASH_set(&PL_compiling, (COPHH*)a1.any_ptr);
+ *(I32*)&PL_hints = a0.any_i32;
if (PL_hints & HINT_LOCALIZE_HH) {
SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
}
assert(GvHV(PL_hintgv));
break;
+
case SAVEt_COMPPAD:
- PL_comppad = (PAD*)ARG0_PTR;
+ a0 = ap[0];
+ PL_comppad = (PAD*)a0.any_ptr;
if (LIKELY(PL_comppad))
PL_curpad = AvARRAY(PL_comppad);
else
PL_curpad = NULL;
break;
+
case SAVEt_PADSV_AND_MORTALIZE:
{
SV **svp;
- assert (ARG1_PTR);
- svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv;
+
+ a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
+ assert (a1.any_ptr);
+ svp = AvARRAY((PAD*)a1.any_ptr) + (PADOFFSET)a2.any_uv;
/* This mortalizing used to be done by CX_POOPLOOP() via
itersave. But as we have all the information here, we
can do it here, save even having to have itersave in
the struct.
*/
sv_2mortal(*svp);
- *svp = ARG2_SV;
+ *svp = a0.any_sv;
}
break;
+
case SAVEt_SAVESWITCHSTACK:
{
dSP;
- SWITCHSTACK(ARG0_AV, ARG1_AV);
- PL_curstackinfo->si_stack = ARG1_AV;
+
+ a0 = ap[0]; a1 = ap[1];
+ SWITCHSTACK(a1.any_av, a0.any_av);
+ PL_curstackinfo->si_stack = a0.any_av;
}
break;
+
case SAVEt_SET_SVFLAGS:
- SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32);
- SvFLAGS(ARG2_SV) |= (U32)ARG0_I32;
+ a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
+ SvFLAGS(a0.any_sv) &= ~(a1.any_u32);
+ SvFLAGS(a0.any_sv) |= a2.any_u32;
break;
/* These are only saved in mathoms.c */
case SAVEt_NSTAB:
- (void)sv_clear(ARG0_SV);
+ a0 = ap[0];
+ (void)sv_clear(a0.any_sv);
break;
+
case SAVEt_LONG: /* long reference */
- *(long*)ARG0_PTR = arg1.any_long;
+ a0 = ap[0]; a1 = ap[1];
+ *(long*)a1.any_ptr = a0.any_long;
break;
+
case SAVEt_IV: /* IV reference */
- *(IV*)ARG0_PTR = arg1.any_iv;
+ a0 = ap[0]; a1 = ap[1];
+ *(IV*)a1.any_ptr = a0.any_iv;
break;
case SAVEt_I16: /* I16 reference */
- *(I16*)ARG0_PTR = (I16)(uv >> 8);
+ a0 = ap[0];
+ *(I16*)a0.any_ptr = (I16)(uv >> 8);
break;
+
case SAVEt_I8: /* I8 reference */
- *(I8*)ARG0_PTR = (I8)(uv >> 8);
+ a0 = ap[0];
+ *(I8*)a0.any_ptr = (I8)(uv >> 8);
break;
+
case SAVEt_DESTRUCTOR:
- (*arg1.any_dptr)(ARG0_PTR);
+ a0 = ap[0]; a1 = ap[1];
+ (*a0.any_dptr)(a1.any_ptr);
break;
+
case SAVEt_COMPILE_WARNINGS:
+ a0 = ap[0];
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
-
- PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR;
+ PL_compiling.cop_warnings = (STRLEN*)a0.any_ptr;
break;
+
case SAVEt_PARSER:
- parser_free((yy_parser *) ARG0_PTR);
+ a0 = ap[0];
+ parser_free((yy_parser *)a0.any_ptr);
break;
+
case SAVEt_READONLY_OFF:
- SvREADONLY_off(ARG0_SV);
+ a0 = ap[0];
+ SvREADONLY_off(a0.any_sv);
break;
+
default:
- Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
+ Perl_croak(aTHX_ "panic: leave_scope inconsistency %u",
+ (U8)uv & SAVE_MASK);
}
}
*
*/
-/* *** these are ordered by number of of auto-popped args */
+/* *** Update arg_counts[] in scope.c if you modify these */
/* zero args */
#define SAVEt_CLEARSV 2
#define SAVEt_REGCONTEXT 3
-#define SAVEt_ARG0_MAX 3
-
/* one arg */
#define SAVEt_TMPSFLOOR 4
#define SAVEt_READONLY_OFF 21
#define SAVEt_FREEPADNAME 22
-#define SAVEt_ARG1_MAX 22
-
/* two args */
#define SAVEt_AV 23
#define SAVEt_ADELETE 46
#define SAVEt_APTR 47
-#define SAVEt_ARG2_MAX 47
-
/* three args */
#define SAVEt_HELEM 48
=for apidoc sv_setpv
Copies a string into an SV. The string must be terminated with a C<NUL>
-character.
+character, and not contain embeded C<NUL>'s.
Does not handle 'set' magic. See C<L</sv_setpv_mg>>.
=cut
if (PL_collation_standard)
goto raw_compare;
- len1 = 0;
- pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
- len2 = 0;
- pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
+ len1 = len2 = 0;
+
+ /* Revert to using raw compare if both operands exist, but either one
+ * doesn't transform properly for collation */
+ if (sv1 && sv2) {
+ pv1 = sv_collxfrm_flags(sv1, &len1, flags);
+ if (! pv1) {
+ goto raw_compare;
+ }
+ pv2 = sv_collxfrm_flags(sv2, &len2, flags);
+ if (! pv2) {
+ goto raw_compare;
+ }
+ }
+ else {
+ pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
+ pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
+ }
if (!pv1 || !len1) {
if (pv2 && len2)
* the hexadecimal values (for %a/%A). The nv is the NV where the value
* are being extracted from (either directly from the long double in-memory
* presentation, or from the uquad computed via frexp+ldexp). frexp also
- * is used to update the exponent. vhex is the pointer to the beginning
- * of the output buffer (of VHEX_SIZE).
+ * is used to update the exponent. The subnormal is set to true
+ * for IEEE 754 subnormals/denormals (including the x86 80-bit format).
+ * The vhex is the pointer to the beginning of the output buffer of VHEX_SIZE.
*
* The tricky part is that S_hextract() needs to be called twice:
* the first time with vend as NULL, and the second time with vend as
* (the extraction of the hexadecimal values) takes place.
* Sanity failures cause fatal failures during both rounds. */
STATIC U8*
-S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
+S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal,
+ U8* vhex, U8* vend)
{
U8* v = vhex;
int ix;
int ixmin = 0, ixmax = 0;
- /* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT,
- * and elsewhere. */
+ /* XXX Inf/NaN are not handled here, since it is
+ * assumed they are to be output as "Inf" and "NaN". */
/* These macros are just to reduce typos, they have multiple
* repetitions below, but usually only one (or sometimes two)
for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
#define HEXTRACT_BYTES_BE(a, b) \
for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_GET_SUBNORMAL(nv) *subnormal = Perl_fp_class_denorm(nv)
#define HEXTRACT_IMPLICIT_BIT(nv) \
STMT_START { \
- if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ if (!*subnormal) { \
+ if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ } \
} STMT_END
-/* Most formats do. Those which don't should undef this. */
+/* Most formats do. Those which don't should undef this.
+ *
+ * But also note that IEEE 754 subnormals do not have it, or,
+ * expressed alternatively, their implicit bit is zero. */
#define HEXTRACT_HAS_IMPLICIT_BIT
+
/* Many formats do. Those which don't should undef this. */
#define HEXTRACT_HAS_TOP_NYBBLE
const U8* vmaxend = vhex + HEXTRACTSIZE;
PERL_UNUSED_VAR(ix); /* might happen */
(void)Perl_frexp(PERL_ABS(nv), exponent);
+ *subnormal = FALSE;
if (vend && (vend <= vhex || vend > vmaxend)) {
/* diag_listed_as: Hexadecimal float: internal error (%s) */
Perl_croak(aTHX_ "Hexadecimal float: internal error (entry)");
#if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
/* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
- * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
+ * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb bf */
/* The bytes 13..0 are the mantissa/fraction,
* the 15,14 are the sign+exponent. */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
# undef HEXTRACT_HAS_TOP_NYBBLE
HEXTRACT_BYTES_LE(13, 0);
/* The bytes 2..15 are the mantissa/fraction,
* the 0,1 are the sign+exponent. */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
# undef HEXTRACT_HAS_TOP_NYBBLE
HEXTRACT_BYTES_BE(2, 15);
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
/* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
- * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
- * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
- * meaning that 2 or 6 bytes are empty padding. */
- /* The bytes 7..0 are the mantissa/fraction */
+ * significand, 15 bits of exponent, 1 bit of sign. No implicit bit.
+ * NVSIZE can be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux
+ * and OS X), meaning that 2 or 6 bytes are empty padding. */
+ /* The bytes 0..1 are the sign+exponent,
+ * the bytes 2..9 are the mantissa/fraction. */
const U8* nvp = (const U8*)(&nv);
# undef HEXTRACT_HAS_IMPLICIT_BIT
# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_BYTES_LE(7, 0);
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
/* Does this format ever happen? (Wikipedia says the Motorola
const U8* nvp = (const U8*)(&nv);
# undef HEXTRACT_HAS_IMPLICIT_BIT
# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_BYTES_BE(0, 7);
# else
# define HEXTRACT_FALLBACK
# ifdef HEXTRACT_LITTLE_ENDIAN
/* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
HEXTRACT_TOP_NYBBLE(6);
HEXTRACT_BYTES_LE(5, 0);
# elif defined(HEXTRACT_BIG_ENDIAN)
/* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
HEXTRACT_TOP_NYBBLE(1);
HEXTRACT_BYTES_BE(2, 7);
# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
/* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
HEXTRACT_TOP_NYBBLE(2); /* 6 */
HEXTRACT_BYTE(1); /* 5 */
# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
/* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
HEXTRACT_TOP_NYBBLE(5); /* 6 */
HEXTRACT_BYTE(6); /* 5 */
# endif
#endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
# ifdef HEXTRACT_FALLBACK
+ HEXTRACT_GET_SUBNORMAL(nv);
# undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
/* The fallback is used for the double-double format, and
* for unknown long double formats, and for unknown double
U8* vend; /* pointer to one beyond last digit of vhex */
U8* vfnz = NULL; /* first non-zero */
U8* vlnz = NULL; /* last non-zero */
+ U8* v0 = NULL; /* first output */
const bool lower = (c == 'a');
/* At output the values of vhex (up to vend) will
* be mapped through the xdig to get the actual
int zerotail = 0; /* how many extra zeros to append */
int exponent = 0; /* exponent of the floating point input */
bool hexradix = FALSE; /* should we output the radix */
+ bool subnormal = FALSE; /* IEEE 754 subnormal/denormal */
+ bool negative = FALSE;
- /* XXX: denormals, NaN, Inf.
+ /* XXX: NaN, Inf -- though they are printed as "NaN" and "Inf".
*
* For example with denormals, (assuming the vanilla
* 64-bit double): the exponent is zero. 1xp-1074 is
* the smallest denormal and the smallest double, it
- * should be output as 0x0.0000000000001p-1022 to
+ * could be output also as 0x0.0000000000001p-1022 to
* match its internal structure. */
- vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
- S_hextract(aTHX_ nv, &exponent, vhex, vend);
+ vend = S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, NULL);
+ S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, vend);
#if NVSIZE > DOUBLESIZE
# ifdef HEXTRACT_HAS_IMPLICIT_BIT
/* In this case there is an implicit bit,
- * and therefore the exponent is shifted shift by one. */
+ * and therefore the exponent is shifted by one. */
exponent--;
# else
- /* In this case there is no implicit bit,
- * and the exponent is shifted by the first xdigit. */
- exponent -= 4;
+# ifdef NV_X86_80_BIT
+ if (subnormal) {
+ /* The subnormals of the x86-80 have a base exponent of -16382,
+ * (while the physical exponent bits are zero) but the frexp()
+ * returned the scientific-style floating exponent. We want
+ * to map the last one as:
+ * -16831..-16384 -> -16382 (the last normal is 0x1p-16382)
+ * -16835..-16388 -> -16384
+ * since we want to keep the first hexdigit
+ * as one of the [8421]. */
+ exponent = -4 * ( (exponent + 1) / -4) - 2;
+ } else {
+ exponent -= 4;
+ }
+# endif
+ /* TBD: other non-implicit-bit platforms than the x86-80. */
# endif
#endif
- if (fv < 0
- || Perl_signbit(nv)
- )
+ negative = fv < 0 || Perl_signbit(nv);
+ if (negative)
*p++ = '-';
else if (plus)
*p++ = plus;
exponent--;
#endif
- if (precis > 0) {
- if ((SSize_t)(precis + 1) < vend - vhex) {
- bool round;
-
- v = vhex + precis + 1;
- /* Round away from zero: if the tail
- * beyond the precis xdigits is equal to
- * or greater than 0x8000... */
- round = *v > 0x8;
- if (!round && *v == 0x8) {
- for (v++; v < vend; v++) {
- if (*v) {
- round = TRUE;
- break;
- }
+ if (subnormal) {
+#ifndef NV_X86_80_BIT
+ if (vfnz[0] > 1) {
+ /* IEEE 754 subnormals (but not the x86 80-bit):
+ * we want "normalize" the subnormal,
+ * so we need to right shift the hex nybbles
+ * so that the output of the subnormal starts
+ * from the first true bit. (Another, equally
+ * valid, policy would be to dump the subnormal
+ * nybbles as-is, to display the "physical" layout.) */
+ int i, n;
+ U8 *vshr;
+ /* Find the ceil(log2(v[0])) of
+ * the top non-zero nybble. */
+ for (i = vfnz[0], n = 0; i > 1; i >>= 1, n++) { }
+ assert(n < 4);
+ vlnz[1] = 0;
+ for (vshr = vlnz; vshr >= vfnz; vshr--) {
+ vshr[1] |= (vshr[0] & (0xF >> (4 - n))) << (4 - n);
+ vshr[0] >>= n;
+ }
+ if (vlnz[1]) {
+ vlnz++;
+ }
+ }
+#endif
+ v0 = vfnz;
+ } else {
+ v0 = vhex;
+ }
+
+ if (has_precis) {
+ U8* ve = (subnormal ? vlnz + 1 : vend);
+ SSize_t vn = ve - (subnormal ? vfnz : vhex);
+ if ((SSize_t)(precis + 1) < vn) {
+ bool overflow = FALSE;
+ if (v0[precis + 1] < 0x8) {
+ /* Round down, nothing to do. */
+ } else if (v0[precis + 1] > 0x8) {
+ /* Round up. */
+ v0[precis]++;
+ overflow = v0[precis] > 0xF;
+ v0[precis] &= 0xF;
+ } else { /* v0[precis] == 0x8 */
+ /* Half-point: round towards the one
+ * with the even least-significant digit:
+ * 08 -> 0 88 -> 8
+ * 18 -> 2 98 -> a
+ * 28 -> 2 a8 -> a
+ * 38 -> 4 b8 -> c
+ * 48 -> 4 c8 -> c
+ * 58 -> 6 d8 -> e
+ * 68 -> 6 e8 -> e
+ * 78 -> 8 f8 -> 10 */
+ if ((v0[precis] & 0x1)) {
+ v0[precis]++;
}
+ overflow = v0[precis] > 0xF;
+ v0[precis] &= 0xF;
}
- if (round) {
- for (v = vhex + precis; v >= vhex; v--) {
- if (*v < 0xF) {
- (*v)++;
+
+ if (overflow) {
+ for (v = v0 + precis - 1; v >= v0; v--) {
+ (*v)++;
+ overflow = *v > 0xF;
+ (*v) &= 0xF;
+ if (!overflow) {
break;
}
- *v = 0;
- if (v == vhex) {
- /* If the carry goes all the way to
- * the front, we need to output
- * a single '1'. This goes against
- * the "xdigit and then radix"
- * but since this is "cannot happen"
- * category, that is probably good. */
- *p++ = xdig[1];
- }
+ }
+ if (v == v0 - 1 && overflow) {
+ /* If the overflow goes all the
+ * way to the front, we need to
+ * insert 0x1 in front, and adjust
+ * the exponent. */
+ Move(v0, v0 + 1, vn, char);
+ *v0 = 0x1;
+ exponent += 4;
}
}
+
/* The new effective "last non zero". */
- vlnz = vhex + precis;
+ vlnz = v0 + precis;
}
else {
- zerotail = precis - (vlnz - vhex);
+ zerotail =
+ subnormal ? precis - vn + 1 :
+ precis - (vlnz - vhex);
}
}
- v = vhex;
+ v = v0;
*p++ = xdig[*v++];
/* If there are non-zero xdigits, the radix
memset(PL_efloatbuf + elen, ' ', width - elen);
}
else if (fill == '0') {
- /* Insert the zeros between the "0x" and
- * the digits, otherwise we end up with
- * "0000xHHH..." */
+ /* Insert the zeros after the "0x" and the
+ * the potential sign, but before the digits,
+ * otherwise we end up with "0000xH.HHH...",
+ * when we want "0x000H.HHH..." */
STRLEN nzero = width - elen;
char* zerox = PL_efloatbuf + 2;
- Move(zerox, zerox + nzero, elen - 2, char);
+ STRLEN nmove = elen - 2;
+ if (negative || plus) {
+ zerox++;
+ nmove--;
+ }
+ Move(zerox, zerox + nzero, nmove, char);
memset(zerox, fill, nzero);
}
else {
parser->multi_start = proto->multi_start;
parser->multi_end = proto->multi_end;
parser->preambled = proto->preambled;
- parser->sublex_info = proto->sublex_info; /* XXX not quite right */
+ parser->lex_super_state = proto->lex_super_state;
+ parser->lex_sub_inwhat = proto->lex_sub_inwhat;
+ parser->lex_sub_op = proto->lex_sub_op;
+ parser->lex_sub_repl= sv_dup_inc(proto->lex_sub_repl, param);
parser->linestr = sv_dup_inc(proto->linestr, param);
parser->expect = proto->expect;
parser->copline = proto->copline;
parser->in_my = proto->in_my;
parser->in_my_stash = hv_dup(proto->in_my_stash, param);
parser->error_count = proto->error_count;
-
-
+ parser->sig_elems = proto->sig_elems;
+ parser->sig_optelems= proto->sig_optelems;
+ parser->sig_slurpy = proto->sig_slurpy;
parser->linestr = sv_dup_inc(proto->linestr, param);
{
PL_forkprocess = proto_perl->Iforkprocess;
/* internal state */
- PL_maxo = proto_perl->Imaxo;
-
PL_main_start = proto_perl->Imain_start;
PL_eval_root = proto_perl->Ieval_root;
PL_eval_start = proto_perl->Ieval_start;
*/
break;
}
+ match = 1;
goto do_op;
/* ops where $_ may be an implicit arg */
=head1 SV Manipulation Functions
=for apidoc Am|U32|SvREFCNT|SV* sv
-Returns the value of the object's reference count.
+Returns the value of the object's reference count. Exposed
+to perl code via Internals::SvREFCNT().
=for apidoc Am|SV*|SvREFCNT_inc|SV* sv
Increments the reference count of the given SV, returning the SV.
* Perl_filter_add() tries to do with the dirp), hence the
* following union trick (as suggested by Gurusamy Sarathy).
* For further information see Geir Johansen's problem report
- * titled [ID 20000612.002] Perl problem on Cray system
+ * titled [ID 20000612.002 (#3366)] Perl problem on Cray system
* The any pointer (known as IoANY()) will also be a good place
* to hang any IO disciplines to.
*/
#define SvOBJECT_on(sv) (SvFLAGS(sv) |= SVs_OBJECT)
#define SvOBJECT_off(sv) (SvFLAGS(sv) &= ~SVs_OBJECT)
+/*
+=for apidoc Am|U32|SvREADONLY|SV* sv
+Returns true if the argument is readonly, otherwise returns false.
+Exposed to to perl code via Internals::SvREADONLY().
+
+=for apidoc Am|U32|SvREADONLY_on|SV* sv
+Mark an object as readonly. Exactly what this means depends on the object
+type. Exposed to perl code via Internals::SvREADONLY().
+
+=for apidoc Am|U32|SvREADONLY_off|SV* sv
+Mark an object as not-readonly. Exactly what this mean depends on the
+object type. Exposed to perl code via Internals::SvREADONLY().
+
+=cut
+*/
+
#define SvREADONLY(sv) (SvFLAGS(sv) & (SVf_READONLY|SVf_PROTECT))
#ifdef PERL_CORE
# define SvREADONLY_on(sv) (SvFLAGS(sv) |= (SVf_READONLY|SVf_PROTECT))
d_ftime='undef'
d_futimes='undef'
d_futimesat='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='stdarg.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs='y'
inc_version_list=''
inc_version_list_init='0'
'../cpan/Locale-Codes' => 1,
'../cpan/Module-Load' => 1,
'../cpan/Module-Load-Conditional' => 1,
- '../cpan/Parse-CPAN-Meta' => 1,
'../cpan/Pod-Simple' => 1,
'../cpan/Test-Simple' => 1,
'../cpan/podlators' => 1,
'../cpan/IO-Compress' => 1,
'../cpan/MIME-Base64' => 1,
'../cpan/parent' => 1,
- '../cpan/Parse-CPAN-Meta' => 1,
'../cpan/Pod-Simple' => 1,
'../cpan/podlators' => 1,
'../cpan/Test-Simple' => 1,
#!./perl
-print "1..107\n";
+print "1..109\n";
$x = 'x';
@bar = ("baz","bonk");
print "not " unless "$foo::@bar" eq "barbaz bonk";
print qq|ok $test - [perl #128478] "\$foo::\@bar"\n|; $test ++;
+
+# Test that compilation of tentative indirect method call syntax which
+# turns out not to be such does not upgrade constants to full globs in the
+# symbol table.
+sub fop() { 0 }
+sub bas() { 0 }
+{ local $SIG{__WARN__}=sub{}; eval 'fop bas'; }
+print "not " unless ref $::{fop} eq 'SCALAR';
+print "ok $test - first constant in 'const1 const2' is not upgraded\n";
+$test++;
+print "not " unless ref $::{bas} eq 'SCALAR';
+print "ok $test - second constant in 'const1 const2' is not upgraded\n";
+$test++;
chdir 't' if -d 't';
}
-print "1..185\n";
+print "1..186\n";
sub failed {
my ($got, $expected, $name) = @_;
eval '%@x=0;';
like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' );
-# Bug 20010422.005
+# Bug 20010422.005 (#6874)
eval q{{s//${}/; //}};
like( $@, qr/syntax error/, 'syntax error, used to dump core' );
-# Bug 20010528.007
+# Bug 20010528.007 (#7052)
eval q/"\x{"/;
like( $@, qr/^Missing right brace on \\x/,
'syntax error in string, used to dump core' );
like( $@, qr/^Illegal declaration of anonymous subroutine/,
'found by Markov chain stress testing' );
-# Bug 20010831.001
+# Bug 20010831.001 (#7605)
eval '($a, b) = (1, 2);';
like( $@, qr/^Can't modify constant item in list assignment/,
'bareword in list assignment' );
eval 'undef foo';
like( $@, qr/^Can't modify constant item in undef operator /,
- 'undefing constant causes a segfault in 5.6.1 [ID 20010906.019]' );
+ 'undefing constant causes a segfault in 5.6.1 [ID 20010906.019 (#7642)]' );
eval 'read($bla, FILE, 1);';
like( $@, qr/^Can't modify constant item in read /,
- 'read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054]' );
+ 'read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054 (#7847)]' );
# This used to dump core (bug #17920)
eval q{ sub { sub { f1(f2();); my($a,$b,$c) } } };
eval 'substr keys(%h),0,=3';
is $@, "", 'substr keys assignment';
+# very large utf8 char in error message was overflowing buffer
+{
+
+ no warnings;
+ eval "q" . chr(100000000064);
+ like $@, qr/Can't find string terminator "." anywhere before EOF/,
+ 'RT 128952';
+}
+
# Add new tests HERE (above this line)
# bug #74022: Loop on characters in \p{OtherIDContinue}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require "./test.pl";
+ set_up_inc('../lib');
}
-BEGIN { require "./test.pl"; }
-
plan(tests => 37);
my ($devnull, $no_devnull);
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
+ set_up_inc(qw(. ../lib));
eval 'use Errno';
die $@ if $@ and !is_miniperl();
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require "./test.pl";
+ set_up_inc('../lib');
+ require "./charset_tools.pl";
}
-BEGIN { require "./test.pl"; require "./charset_tools.pl"; }
-
plan(tests => 3);
# It is important that the script contains at least one newline character
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl';
+ require "./test.pl";
+ set_up_inc('../lib');
}
if ($^O eq 'dos') {
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
- require "./test.pl"; require "charset_tools.pl";
+ require "./test.pl";
+ set_up_inc('../lib');
+ require "./charset_tools.pl";
skip_all_without_perlio();
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl';
+ require "./test.pl";
+ set_up_inc('../lib');
}
$|=1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 16;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require "./test.pl";
+ set_up_inc(qw(. ../lib));
}
use Config;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_without_dynamic_extension('Fcntl');
}
use strict;
use Config;
-require './test.pl';
-
my $piped;
eval {
pipe my $in, my $out;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl';
+ require "./test.pl";
+ set_up_inc('../lib');
skip_all_if_miniperl("No XS under miniperl");
}
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ require "./test.pl";
+ set_up_inc( qw(. ../lib) );
}
require Config; import Config;
-require "./test.pl";
plan(tests => 1);
SKIP: {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
# Script to test auto flush on fork/exec/system/qx. The idea is to
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require "./test.pl";
+ set_up_inc('../lib');
}
use Config;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_if_miniperl("miniperl can't load IO::File");
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_without_perlio();
# FIXME - more of these could be tested without Encode or full perl
skip_all_without_dynamic_extension('Encode');
# Check that PL_sigwarn's reference count is correct, and that
# &PerlIO::Layer::NoWarnings isn't prematurely freed.
- fresh_perl_like (<<"EOT", qr/^CODE/);
+ fresh_perl_like (<<"EOT", qr/^CODE/, {}, "Check PL_sigwarn's reference count");
open(UTF, "<:raw:encoding(utf8)", '$afile') or die \$!;
print ref *PerlIO::Layer::NoWarnings{CODE};
EOT
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require "./test.pl";
+ set_up_inc('../lib');
}
print "1..5\n";
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
$| = 1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
if ($^O eq 'dos') {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require Config; import Config;
- require './test.pl';
+ require './test.pl';
+ set_up_inc('../lib');
skip_all_without_perlio();
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require "../t/test.pl";
+ set_up_inc('../lib');
skip_all_without_perlio();
- plan (15);
}
+plan (15);
+
use warnings 'layer';
my $warn;
my $file = "fail$$";
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_without_perlio();
skip_all_without_dynamic_extension('Fcntl'); # how did you get this far?
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require Config; import Config;
require './test.pl';
-
- if (!$Config{'d_fork'}) {
- skip_all("fork required to pipe");
- }
- else {
- plan(tests => 24);
- }
+ set_up_inc('../lib');
+}
+if (!$Config{'d_fork'}) {
+ skip_all("fork required to pipe");
+}
+else {
+ plan(tests => 24);
}
my $Perl = which_perl();
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
eval 'use Errno';
die $@ if $@ and !is_miniperl();
}
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require "./test.pl";
+ set_up_inc(qw(. ../lib));
}
BEGIN { $| = 1 }
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
eval 'use Errno';
die $@ if $@ and !is_miniperl();
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
eval 'use Errno';
die $@ if $@ and !is_miniperl();
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib' && -d '../ext';
require "./test.pl";
+ set_up_inc( '../lib' ) if -d '../lib' && -d '../ext';
require Config; import Config;
if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
################################################################################
BEGIN {
- if ($ENV{'PERL_CORE'}) {
- chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib' && -d '../ext';
- }
-
+ chdir 't' if -d 't' && $ENV{'PERL_CORE'};
require "./test.pl";
+ set_up_inc('../lib') if $ENV{'PERL_CORE'} && -d '../lib' && -d '../ext';
+
require Config; import Config;
if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib' && -d '../ext';
require "./test.pl";
+ set_up_inc( '../lib' ) if -d '../lib' && -d '../ext';
require Config; import Config;
skip_all_if_miniperl();
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
print "1..35\n";
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all("VMS too picky about line endings for record-oriented pipes")
if $^O eq 'VMS';
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl'; require './charset_tools.pl';
- skip_all_without_perlio();
+ set_up_inc('../lib');
}
+skip_all_without_perlio();
no utf8; # needed for use utf8 not griping about the raw octets
print "ARGV = [@ARGV]\n";
@w_files = map { "./lib/$pragma_name/$_" } @ARGV;
} else {
- @w_files = sort glob catfile(curdir(), "lib", $pragma_name, "*");
+ @w_files = sort grep !/( \.rej | ~ | \ \(Autosaved\)\.txt ) \z/nx,
+ glob catfile(curdir(), "lib", $pragma_name, "*");
}
my ($tests, @prgs) = setup_multiple_progs(@w_files);
EXPECT
Can't find string terminator "foo" anywhere before EOF at - line 1.
########
+# NAME Unterminated here-doc with non-Latin-1 terminator
+BEGIN { binmode STDERR, ":utf8" }
+use utf8;
+<<옷옷
+EXPECT
+Can't find string terminator "옷옷" anywhere before EOF at - line 3.
+########
# NAME Unterminated qw//
qw/
EXPECT
EXPECT
Can't find string terminator "'" anywhere before EOF at - line 1.
########
+# NAME Unterminated q// with non-ASCII delimiter, under utf8
+BEGIN { binmode STDERR, ":utf8" }
+use utf8;
+q«
+EXPECT
+Can't find string terminator "«" anywhere before EOF at - line 3.
+########
+# NAME Unterminated q// with non-Latin-1 delimiter
+BEGIN { binmode STDERR, ":utf8" }
+use utf8;
+q 옷
+EXPECT
+Can't find string terminator "옷" anywhere before EOF at - line 3.
+########
# NAME /\N{/
/\N{/
EXPECT
Version control conflict marker at - line 3, near "======="
Version control conflict marker at - line 5, near ">>>>>>>"
Execution of - aborted due to compilation errors.
+########
+# NAME (Might be a runaway multi-line...) with Latin-1 delimiters in utf8
+BEGIN { binmode STDERR, ':utf8' }
+use utf8;
+q«
+« time
+EXPECT
+syntax error at - line 4, near "« time"
+ (Might be a runaway multi-line «« string starting on line 3)
+Execution of - aborted due to compilation errors.
+########
+# NAME (Might be a runaway multi-line...) with non-Latin-1 delimiters
+BEGIN { binmode STDERR, ':utf8' }
+use utf8;
+q ϡ
+ϡ time
+EXPECT
+syntax error at - line 4, near "ϡ time"
+ (Might be a runaway multi-line ϡϡ string starting on line 3)
+Execution of - aborted due to compilation errors.
}
{
- # Bug ID 20001013.009
+ # Bug ID 20001013.009 (#4434)
#
# test that $hash{KEY} = undef doesn't produce the warning
# Use of uninitialized value in null operation
########
-# ID 20020703.002
+# ID 20020703.002 (#10021)
use strict;
use warnings;
my $abc = XYZ ? 1 : 0;
sub tryit { eval shift or warn \$@ }
tryit "&Internals::SvREADONLY($arg)";
tryit "&Internals::SvREFCNT($arg)";
-tryit "&Internals::hv_clear_placeholders($arg)";
----
Usage: Internals::SvREADONLY(SCALAR[, ON]) at (eval 1) line 1.
Usage: Internals::SvREFCNT(SCALAR[, REFCOUNT]) at (eval 2) line 1.
-Usage: Internals::hv_clear_placeholders(hv) at (eval 3) line 1.
====
}
EXPECT
ok
Use of uninitialized value $a[140688675223280] in string at - line 15.
+########
+# RT #128940
+use warnings 'uninitialized';
+my $x = "" . open my $fh, "<", "no / such / file";
+EXPECT
+Use of uninitialized value in concatenation (.) or string at - line 3.
$123; # numbers
$_; # and
$_foo; # underscores (none of which should warn)
+@DB::args
+EXPECT
+########
+-w
+# perl.c
+print # avoid void warning
+$\, # test a few
+$:, # punct vars
+$0, # and
+$123, # numbers
+$_, # and
+$_foo, # underscores (none of which should warn)
+@DB::args
+if 0;
EXPECT
########
-W
(Are you trying to call print() on dirhandle STDIN?)
########
# pp_hot.c [pp_print]
-# [ID 20020425.012] from Dave Steiner <steiner@bakerst.rutgers.edu>
+# [ID 20020425.012 (#9030)] from Dave Steiner <steiner@bakerst.rutgers.edu>
# This goes segv on 5.7.3
use warnings 'closed' ;
my $fh = *STDOUT{IO};
Invalid type ',' in unpack at - line 4.
Invalid type ',' in pack at - line 5.
########
-# pp.c
-use warnings 'uninitialized' ;
-my $a = undef ;
-my $b = $$a;
-no warnings 'uninitialized' ;
-my $c = $$a;
-EXPECT
-Use of uninitialized value $a in scalar dereference at - line 4.
-########
# pp_pack.c
use warnings 'pack' ;
sub foo { my $a = "a"; return $a . $a++ . $a++ }
my $a = pack("p", &foo) ;
+@a = "foo";
+sub bar { pop @{\@_}, pack "p", $a[0] } # This should *not* warn, even
+bar(@a); # though $a[0] is SvTEMP.
no warnings 'pack' ;
my $b = pack("p", &foo) ;
EXPECT
Attempt to pack pointer to temporary value at - line 4.
########
-# pp.c
-use warnings 'misc' ;
-bless \[], "" ;
-no warnings 'misc' ;
-bless \[], "" ;
-EXPECT
-Explicit blessing to '' (assuming package main) at - line 3.
-########
-# pp.c
-use utf8 ;
-$_ = "\x80 \xff" ;
-reverse ;
-EXPECT
-########
# pp_pack.c
use warnings 'pack' ;
print unpack("C", pack("C", -1)), "\n",
EXPECT
Use of uninitialized value $A in concatenation (.) or string at - line 10.
########
-# perlbug 20011116.125
+# perlbug 20011116.125 (#7917)
use warnings 'uninitialized';
$a = undef;
$foo = join '', $a, "\n";
EXPECT
Possible unintended interpolation of @mjd_previously_unused_ぁrrぁy in string at - line 5.
########
+-w
+# toke.c
+$_ = "@DB::args";
+EXPECT
+########
# toke.c
# 20020328 mjd-perl-patch+@plover.com at behest of jfriedl@yahoo.com
use warnings 'regexp';
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require q(./test.pl);
+ set_up_inc('../lib');
}
use strict;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ require q(./test.pl);
+ set_up_inc('../lib');
}
use strict;
use warnings;
-require q(./test.pl); plan(tests => 1);
+plan(tests => 1);
require mro;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ require q(./test.pl);
+ set_up_inc('../lib');
}
use strict;
use utf8;
use open qw( :utf8 :std );
-require q(./test.pl); plan(tests => 1);
+plan(tests => 1);
require mro;
#!./perl
-BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl' }
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
+}
plan 13;
#!./perl
-BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl' }
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
+}
use utf8;
use open qw( :utf8 :std );
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require "./test.pl";
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require "./test.pl";
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require "./test.pl";
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require "./test.pl";
+ set_up_inc('../lib');
}
use strict;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
require q(./test.pl);
+ set_up_inc('../lib') unless -d 'blib';
}
use strict;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
require q(./test.pl);
+ set_up_inc('../lib');
}
use strict;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ require './test.pl';
+ set_up_inc('../lib');
}
use utf8;
no warnings 'redefine'; # we do a lot of this
no warnings 'prototype'; # we do a lot of this
-require './test.pl';
-
{
package MC텟ᵀ::Bࡎᶓ;
sub ᕘ { return $_[1]+1 };
use strict;
use warnings;
-BEGIN { chdir 't' if -d 't'; require q(./test.pl); @INC = qw "../lib lib" }
+BEGIN { chdir 't' if -d 't'; require q(./test.pl);
+set_up_inc('../lib', 'lib');
+}
plan(tests => 12);
use strict;
use warnings;
-BEGIN { chdir 't' if -d 't'; require q(./test.pl); @INC = qw "../lib lib" }
+BEGIN {
+ chdir 't' if -d 't';
+ require q(./test.pl);
+ set_up_inc('../lib', 'lib');
+}
use utf8;
use open qw( :utf8 :std );
SKIP: {
eval 'use Sub::Name';
skip("Sub::Name is required for this test", 3) if $@;
-
+
my $m = sub { (shift)->next::method() };
Sub::Name::subname('Baɾ::ƚ', $m);
{
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ require q(./test.pl);
+ set_up_inc('../lib');
}
-require q(./test.pl); plan(tests => 7);
+plan(tests => 7);
{
package BaseTest;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ require q(./test.pl);
+ set_up_inc('../lib');
}
use utf8;
use open qw( :utf8 :std );
-require q(./test.pl); plan(tests => 7);
+plan(tests => 7);
{
package 밧e텟ʇ;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ require q(./test.pl);
+ set_up_inc('../lib');
}
-require q(./test.pl); plan(tests => 7);
+plan(tests => 7);
{
package BaseTest;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
require q(./test.pl);
+ set_up_inc('../lib');
}
use strict;
$ENV{PERL_UNICODE} = 0;
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
require q(./test.pl);
+ set_up_inc('../lib');
}
use strict;
#!./perl
BEGIN {
+ require './test.pl';
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ set_up_inc('../lib');
}
-require './test.pl';
-
use strict;
use warnings;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ require './test.pl';
+ set_up_inc('../lib');
}
use utf8;
use open qw( :utf8 :std );
-require './test.pl';
-
plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
plan(tests => 8);
#!./perl
BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
}
use strict;
use warnings;
-require './test.pl';
-
plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
plan(tests => 8);
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
- @INC = '../lib';
}
+ require './test.pl';
+ set_up_inc('../lib');
}
use utf8;
use open qw( :utf8 :std );
-require './test.pl';
-
plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
plan(tests => 8);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
eval { my $q = pack "q", 0 };
skip_all('no 64-bit types') if $@;
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib')
}
use warnings;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
-BEGIN {
- use Config;
- if( !$Config{d_alarm} ) {
- skip_all("alarm() not implemented on this platform");
- }
+
+use Config;
+if ( !$Config{d_alarm} ) {
+ skip_all("alarm() not implemented on this platform");
}
plan tests => 5;
BEGIN {
chdir 't';
require './test.pl';
- @INC = "../lib";
+ set_up_inc("../lib");
}
plan 8;
#!./perl -w
chdir 't' if -d 't';
-@INC = '../lib';
require './test.pl';
+set_up_inc('../lib');
+
use strict;
$|=1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
##Literal test count since evals below can fail
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc('../lib');
}
-require './test.pl';
plan( tests => 23 );
# test various operations on @_
BEGIN {
chdir 't' if -d 't';
- @INC = ('.', '../lib');
require './test.pl';
+ set_up_inc('.', '../lib');
}
plan (173);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_if_miniperl("miniperl can't load attributes");
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_if_miniperl("miniperl can't load attributes");
}
use warnings;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_if_miniperl("miniperl can't load attributes");
}
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require "./test.pl";
+ set_up_inc(qw(. ../lib));
}
plan( tests => 47 );
};
not_hash($@);
-# Check hash slices (BUG ID 20010423.002)
+# Check hash slices (BUG ID 20010423.002 (#6879))
$avhv = [{foo=>1, bar=>2}];
eval {
@$avhv{"foo", "bar"} = (42, 53);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan (114);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require "./test.pl"; require "./charset_tools.pl";
+ require "./test.pl";
+ set_up_inc('../lib');
+ require "./charset_tools.pl";
require Config;
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
- plan( tests => 96 );
+ set_up_inc('../lib');
+ plan( tests => 96 ); # some tests are run in a BEGIN block
}
my @c;
is( $c[3], "main::__ANON__", "anonymous subroutine name" );
ok( $c[4], "hasargs true with anon sub" );
-# Bug 20020517.003, used to dump core
+# Bug 20020517.003 (#9367), used to dump core
sub foo { @c = caller(0) }
my $fooref = delete $::{foo};
$fooref -> ();
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 34;
# We're not going to chdir() into 't' because we don't know if
# chdir() works! Instead, we'll hedge our bets and put both
# possibilities into @INC.
- unshift @INC, qw(t . lib ../lib);
- require "test.pl";
- plan(tests => 47);
+ require "./test.pl";
+ set_up_inc(qw(t . lib ../lib));
}
+plan(tests => 47);
+
use Config;
use Errno qw(ENOENT EBADF EINVAL);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl'; require './charset_tools.pl';
+ require './test.pl';
+ set_up_inc('../lib');
+ require './charset_tools.pl';
}
my $tests_count = 148;
my @stuff = qw(this that);
is (chop(@stuff[0,1]), 't');
-# bug id 20010305.012
+# bug id 20010305.012 (#5972)
@stuff = qw(ab cd ef);
is (chop(@stuff = @stuff), 'f');
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib); # ../lib needed for test.deparse
require "./test.pl";
+ set_up_inc(qw(. ../lib)); # ../lib needed for test.deparse
}
plan tests => 45;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan 2;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
is( 1 ? 1 : 0, 1, 'compile time, true' );
BEGIN {
chdir 't';
require './test.pl';
- @INC = '../lib';
+ set_up_inc('../lib');
}
plan 168;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ require "./test.pl";
+ set_up_inc( qw(. ../lib) );
}
require "./test.pl";
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib ../dist/if);
require "./test.pl"; require './charset_tools.pl';
$^P |= 0x100;
+ set_up_inc( qw(. ../lib ../dist/if) );
}
no warnings 'experimental::smartmatch';
lis [sort &mykeys({1..4})], [1,3], '&mykeys(\%hash) in list cx';
is &mykeys([ 1..4 ]), 4, '&mykeys(\@array) in scalar cx';
lis [&mykeys([ 1..4 ])], [0..3], '&mykeys(\@array) in list cx';
-{
+
+SKIP: {
+ skip "no Hash::Util on miniperl", 2, if is_miniperl;
+ require Hash::Util;
+ sub Hash::Util::bucket_ratio (\%);
+
my %h = 1..2;
&mykeys(\%h) = 1024;
like Hash::Util::bucket_ratio(%h), qr|/1024\z|, '&mykeys = changed number of buckets allocated';
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require "./test.pl";
+ set_up_inc(qw(. ../lib));
skip_all_without_dynamic_extension('B');
$^P |= 0x100;
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc('../lib');
}
-BEGIN { require './test.pl'; }
plan tests => 254;
while (<DATA>) {
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
-}
-
-BEGIN {
- use Config;
-
require "./test.pl";
+ set_up_inc( qw(. ../lib) );
+ use Config;
+}
- if( !$Config{d_crypt} ) {
- skip_all("crypt unimplemented");
- }
- else {
- plan(tests => 6);
- }
+if ( !$Config{d_crypt} ) {
+ skip_all("crypt unimplemented");
}
+else {
+ plan(tests => 6);
+}
+
# Can't assume too much about the string returned by crypt(),
# and about how many bytes of the encrypted (really, hashed)
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib);
require './test.pl';
- plan (tests => 22);
+ set_up_inc( qw(../lib) );
+ plan (tests => 22); # some tests are run in BEGIN block
}
is __SUB__, "__SUB__", '__SUB__ is a bareword outside of use feature';
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
eval { require AnyDBM_File }; # not all places have dbm* functions
skip_all("No dbm functions") if $@;
plan tests => 5;
-# This is [20020104.007] "coredump on dbmclose"
+# This is [20020104.007 (#8179)] "coredump on dbmclose"
my $filename = tempfile();
set_up_inc('../lib');
}
-plan 188;
+plan 402;
for my $decl (qw< my CORE::state our local >) {
for my $funny (qw< $ @ % >) {
# Test three syntaxes with each declarator/funny char combination:
- # my \$foo my(\$foo) my\($foo)
+ # my \$foo my(\$foo) my\($foo) for my \$foo
for my $code("$decl \\${funny}x", "$decl\(\\${funny}x\)",
- "$decl\\\(${funny}x\)") {
+ "$decl\\\(${funny}x\)",
+ "for $decl \\${funny}x (\\${funny}y) {}") {
+ SKIP: {
+ skip "for local is illegal", 3 if $code =~ /^for local/;
eval $code;
like
$@,
is $c, 1, "one warning from $code";
like $w, qr/^Declaring references is experimental at /,
"experimental warning for $code";
+ }
}
}
}
no warnings 'experimental::declared_refs';
for $decl ('my', 'state', 'our', 'local') {
+for $sigl ('$', '@', '%') {
+ # The weird code that follows uses ~ as a sigil placeholder and MY
+ # as a declarator placeholder.
my $code = '#line ' . (__LINE__+1) . ' ' . __FILE__ . "\n" . <<'END';
- my $ret = MY \$a;
- is $ret, \$a, 'MY \$a returns ref to $a';
- isnt $ret, \$::a, 'MY \$a ret val is not pkg var';
- my @ret = MY \($b, $c);
- is "@ret", \$b." ".\$c, 'MY \($b, $c) returns correct refs';
- isnt $ret[0], \$::b, 'first retval of MY \($b, $c) is not pkg var';
- isnt $ret[1], \$::c, '2nd retval of MY \($b, $c) is not pkg var';
- @ret = MY (\($d, $e));
- is "@ret", \$d." ".\$e, 'MY (\($d, $e)) returns correct refs';
- isnt $ret[0], \$::d, 'first retval of MY (\($d, $e)) is not pkg var';
- isnt $ret[1], \$::e, '2nd retval of MY (\($d, $e)) is not pkg var';
- @ret = \MY (\$f, $g);
- is ${$ret[0]}, \$f, 'first retval of MY (\$f, $g) is \$f';
- isnt ${$ret[0]}, \$::f, 'first retval of MY (\$f, $g) is not \$::f';
- is $ret[1], \$g, '2nd retval of MY (\$f, $g) is $g';
- isnt $ret[1], \$::g, '2nd retval of MY (\$f, $g) is not $::g';
+ my $ret = MY \~a;
+ is $ret, \~a, 'MY \$a returns ref to $a';
+ isnt $ret, \~::a, 'MY \$a ret val is not pkg var';
+ my @ret = MY \(~b, ~c);
+ is "@ret", \~b." ".\~c, 'MY \(~b, ~c) returns correct refs';
+ isnt $ret[0], \~::b, 'first retval of MY \(~b, ~c) is not pkg var';
+ isnt $ret[1], \~::c, '2nd retval of MY \(~b, ~c) is not pkg var';
+ @ret = MY (\(~d, ~e));
+ is "@ret", \~d." ".\~e, 'MY (\(~d, ~e)) returns correct refs';
+ isnt $ret[0], \~::d, 'first retval of MY (\(~d, ~e)) is not pkg var';
+ isnt $ret[1], \~::e, '2nd retval of MY (\(~d, ~e)) is not pkg var';
+ @ret = \MY (\~f, ~g);
+ is ${$ret[0]}, \~f, 'first retval of MY (\~f, ~g) is \~f';
+ isnt ${$ret[0]}, \~::f, 'first retval of MY (\~f, ~g) is not \~::f';
+ is $ret[1], \~g, '2nd retval of MY (\~f, ~g) is ~g';
+ isnt $ret[1], \~::g, '2nd retval of MY (\~f, ~g) is not ~::g';
*MODIFY_SCALAR_ATTRIBUTES = sub {
- is @_, 3, 'MY \$h : risible calls handler with right no. of args';
- is $_[2], 'risible', 'correct attr passed by MY \$h : risible';
+ is @_, 3, 'MY \~h : risible calls handler with right no. of args';
+ is $_[2], 'risible', 'correct attr passed by MY \~h : risible';
return;
};
SKIP : {
unless ('MY' eq 'local') {
skip_if_miniperl "No attributes on miniperl", 2;
- eval 'MY \$h : risible' or die $@ unless 'MY' eq 'local';
+ eval 'MY \~h : risible' or die $@ unless 'MY' eq 'local';
}
}
- eval 'MY \$a ** 1';
+ eval 'MY \~a ** 1';
like $@,
qr/^Can't (?:declare|modify) exponentiation \(\*\*\) in "?MY"? at/,
- 'comp error for MY \$a ** 1';
- $ret = MY \\$i;
- is $$ret, \$i, 'retval of MY \\$i is ref to ref to $i';
- $ret = MY \\$i;
- isnt $$ret, \$::i, 'retval of MY \\$i is ref to ref to $::i';
- $ret = MY (\\$i);
- is $$ret, \$i, 'retval of MY (\\$i) is ref to ref to $i';
- $ret = MY (\\$i);
- isnt $$ret, \$::i, 'retval of MY (\\$i) is ref to ref to $::i';
+ 'comp error for MY \~a ** 1';
+ $ret = MY \\~i;
+ is $$ret, \~i, 'retval of MY \\~i is ref to ref to ~i';
+ $ret = MY \\~i;
+ isnt $$ret, \~::i, 'retval of MY \\~i is ref to ref to ~::i';
+ $ret = MY (\\~i);
+ is $$ret, \~i, 'retval of MY (\\~i) is ref to ref to ~i';
+ $ret = MY (\\~i);
+ isnt $$ret, \~::i, 'retval of MY (\\~i) is ref to ref to ~::i';
*MODIFY_SCALAR_ATTRIBUTES = sub {
- is @_, 3, 'MY (\$h) : bumpy calls handler with right no. of args';
- is $_[2], 'bumpy', 'correct attr passed by MY (\$h) : bumpy';
+ is @_, 3, 'MY (\~h) : bumpy calls handler with right no. of args';
+ is $_[2], 'bumpy', 'correct attr passed by MY (\~h) : bumpy';
return;
};
SKIP : {
unless ('MY' eq 'local') {
skip_if_miniperl "No attributes on miniperl", 2;
- eval 'MY (\$h) : bumpy' or die $@;
+ eval 'MY (\~h) : bumpy' or die $@;
}
}
1;
END
$code =~ s/MY/$decl/g;
+ $code =~ s/~/$sigl/g;
+ $code =~ s/MODIFY_\KSCALAR/$sigl eq '@' ? "ARRAY" : "HASH"/eggnog
+ if $sigl ne '$';
if ($decl =~ /^(?:our|local)\z/) {
$code =~ s/is ?no?t/is/g; # tests for package vars
}
eval $code or die $@;
-}
+}}
+
+use feature 'refaliasing'; no warnings "experimental::refaliasing";
+for $decl ('my', 'state', 'our') {
+for $sigl ('$', '@', '%') {
+ my $code = '#line ' . (__LINE__+1) . ' ' . __FILE__ . "\n" . <<'ENE';
+ for MY \~x (\~::y) {
+ is \~x, \~::y, '\~x aliased by for MY \~x';
+ isnt \~x, \~::x, '\~x is not equivalent to \~::x';
+ }
+ 1;
+ENE
+ $code =~ s/MY/$decl/g;
+ $code =~ s/~/$sigl/g;
+ $code =~ s/is ?no?t/is/g if $decl eq 'our';
+ eval $code or die $@;
+}}
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ require './test.pl';
+ set_up_inc( qw(. ../lib) );
$SIG{__WARN__} = sub { $warns++; warn $_[0] };
}
-require './test.pl';
+
plan( tests => 27 );
my $unix_mode = 1;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ require "./test.pl";
+ set_up_inc( qw(. ../lib) );
}
-require "./test.pl";
plan( tests => 38 );
# delete() on hash elements
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 19;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
require './test.pl';
- plan(24);
}
+plan(24);
+
sub End::DESTROY { $_[0]->() }
sub end(&) {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc( '../lib' );
}
use strict;
no warnings 'void';
do $file18; die $@ if $@;
-# bug ID 20010920.007
+# bug ID 20010920.007 (#7713)
eval qq{ do qq(a file that does not exist); };
is($@, '', "do on a non-existing file, first try");
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require "./test.pl";
+ set_up_inc('../lib');
}
package main;
-require './test.pl';
plan( tests => 34 );
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
-
+ set_up_inc( qw(. ../lib) );
skip_all_if_miniperl();
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 59;
@keys = ('blurfl', keys(%h), 'dyick');
is ($#keys, 31, "added a key");
-$size = Hash::Util::num_buckets(%h);
-keys %h = $size * 5;
-$newsize = Hash::Util::num_buckets(%h);
-is ($newsize, $size * 8, "resize");
-keys %h = 1;
-$size = Hash::Util::num_buckets(%h);
-is ($size, $newsize, "same size");
-%h = (1,1);
-$size = Hash::Util::num_buckets(%h);
-is ($size, $newsize, "still same size");
-undef %h;
-%h = (1,1);
-$size = Hash::Util::num_buckets(%h);
-is ($size, 8, "size 8");
+SKIP: {
+ skip "no Hash::Util on miniperl", 4, if is_miniperl;
+ require Hash::Util;
+ sub Hash::Util::num_buckets (\%);
+
+ $size = Hash::Util::num_buckets(%h);
+ keys %h = $size * 5;
+ $newsize = Hash::Util::num_buckets(%h);
+ is ($newsize, $size * 8, "resize");
+ keys %h = 1;
+ $size = Hash::Util::num_buckets(%h);
+ is ($size, $newsize, "same size");
+ %h = (1,1);
+ $size = Hash::Util::num_buckets(%h);
+ is ($size, $newsize, "still same size");
+ undef %h;
+ %h = (1,1);
+ $size = Hash::Util::num_buckets(%h);
+ is ($size, 8, "size 8");
+}
# test scalar each
%hash = 1..20;
$total += $key while $key = each %hash;
is ($total, 100, "test values keys resets iterator");
-$size = Hash::Util::num_buckets(%hash);
-keys(%hash) = $size / 2;
-is ($size, Hash::Util::num_buckets(%hash),
- "assign to keys does not shrink hash bucket array");
-keys(%hash) = $size + 100;
-isnt ($size, Hash::Util::num_buckets(%hash),
- "assignment to keys of a number not large enough does not change size");
-
-is (keys(%hash), 10, "keys (%hash)");
+SKIP: {
+ skip "no Hash::Util on miniperl", 3, if is_miniperl;
+ require Hash::Util;
+ sub Hash::Util::num_buckets (\%);
+
+ $size = Hash::Util::num_buckets(%hash);
+ keys(%hash) = $size / 2;
+ is ($size, Hash::Util::num_buckets(%hash),
+ "assign to keys does not shrink hash bucket array");
+ keys(%hash) = $size + 100;
+ isnt ($size, Hash::Util::num_buckets(%hash),
+ "assignment to keys of a number not large enough does not change size");
+ is (keys(%hash), 10, "keys (%hash)");
+}
@tests = (&next_test, &next_test, &next_test);
{
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
use warnings;
}
# Check that eval catches bad goto calls
-# (BUG ID 20010305.003)
+# (BUG ID 20010305.003 (#5963))
{
eval {
eval { goto foo; };
{
$@ = 5;
eval q{};
- cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
+ cmp_ok(length $@, '==', 0, '[ID 20020623.002 (#9721)] eval "" doesn\'t clear $@');
}
# DAPM Nov-2002. Perl should now capture the full lexical context during
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl'; require './charset_tools.pl';
+ require './test.pl';
+ set_up_inc('../lib');
+ require './charset_tools.pl';
}
plan(tests => 8);
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib');
require './test.pl';
+ set_up_inc('../lib');
}
my $vms_exit_mode = 0;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
sub t1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use Config;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 8;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_if_miniperl("no dynamic loading on miniperl, no IO, hence no FileHandle");
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
my @ops = split //, 'rwxoRWXOezsfdlpSbctugkTMBAC';
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
ok(($x...$x) eq "1");
{
- # coredump reported in bug 20001018.008
+ # coredump reported in bug 20001018.008 (#4474)
readline(UNKNOWN);
$. = 1;
$x = 1..10;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
require Config;
skip_all('no fork')
unless ($Config::Config{d_fork} or $Config::Config{d_pseudofork});
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan 1;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib);
require './test.pl';
+ set_up_inc( qw(../lib) );
+ skip_all_if_miniperl(
+ "no dynamic loading on miniperl, no threads/attributes"
+ );
}
use strict;
use Config;
-BEGIN {
+{
skip_all_without_config(qw(useithreads d_getppid));
- skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
eval 'use threads; use threads::shared';
plan tests => 3;
if ($@) {
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib);
+ require './test.pl';
+ set_up_inc( qw(../lib) );
}
use strict;
-BEGIN {
- require './test.pl';
- skip_all_without_config(qw(d_pipe d_fork d_waitpid d_getppid));
- plan (8);
-}
+skip_all_without_config(qw(d_pipe d_fork d_waitpid d_getppid));
+plan (8);
# No, we don't want any zombies. kill 0, $ppid spots zombies :-(
$SIG{CHLD} = 'IGNORE';
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
+ set_up_inc( qw(. ../lib) );
}
plan( tests => 18 );
print "ok2" if $output1 eq $output2;
}
EOP
-}
\ No newline at end of file
+}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require "./test.pl"; require './charset_tools.pl';
+ set_up_inc( qw(. ../lib) );
}
use warnings;
is($count, 2, 'end of loop');
# Does goto work correctly within a for(;;) loop?
-# (BUG ID 20010309.004)
+# (BUG ID 20010309.004 (#5998))
for(my $i=0;!$i++;) {
my $x=1;
require './test.pl';
# turn warnings into fatal errors
$SIG{__WARN__} = sub { die "WARNING: @_" } ;
-
+ set_up_inc('../lib');
skip_all_if_miniperl("no dynamic loading on miniperl, no Fcntl");
require Fcntl;
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
eval {my @n = getgrgid 0};
#
BEGIN {
- chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ chdir 't' if -d 't';
require "./test.pl";
+ set_up_inc( qw(. ../lib) );
}
plan( tests => 67 );
$ENV{LANGUAGE} = 'C'; # GNU locale extension
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc( '../lib' );
skip_all_if_miniperl("no dynamic loading on miniperl, no POSIX");
}
+
use 5.010;
use strict;
use Config ();
ok(defined *{$a});
}
-# [ID 20010526.001] localized glob loses value when assigned to
+# [ID 20010526.001 (#7038)] localized glob loses value when assigned to
$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc( '../lib' );
skip_all_without_dynamic_extension("Devel::Peek");
}
is($scalar, $count, "$desc scalar() should be the same as 0+keys() as of perl 5.25");
+ require Hash::Util;
+ sub Hash::Util::bucket_ratio (\%);
+
# back compat tests, via Hash::Util::bucket_ratio();
my $ratio = Hash::Util::bucket_ratio(%$h);
my $expect = qr!\A(\d+)/(\d+)\z!;
is(scalar %$h1, scalar %$h, "scalar keys is identical on copy and original");
}
-torture_hash('a .. zz', 'a' .. 'zz');
-torture_hash('0 .. 9', 0 .. 9);
-torture_hash("'Perl'", 'Rules');
+if (is_miniperl) {
+ print "# skipping torture_hash tests on miniperl because no Hash::Util\n";
+} else {
+ torture_hash('a .. zz', 'a' .. 'zz');
+ torture_hash('0 .. 9', 0 .. 9);
+ torture_hash("'Perl'", 'Rules');
+}
{
my %h = qw(a x b y c z);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
# use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ require './test.pl';
+ set_up_inc( qw(. ../lib) );
}
-require './test.pl';
plan( tests => 18 );
use strict;
# tests for heredocs besides what is tested in base/lex.t
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl';
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
use Config;
-plan(tests => 105);
+plan(tests => 109);
# Test hexfloat literals.
}
}
+# [perl #128919] limited exponent range in hex fp literal with long double
+SKIP: {
+ skip("non-80-bit-long-double", 4)
+ unless ($Config{uselongdouble} &&
+ ($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
+ ($Config{longdblkind} == 3 ||
+ $Config{longdblkind} == 4));
+ is(0x1p-1074, 4.94065645841246544e-324);
+ is(0x1p-1075, 2.47032822920623272e-324, '[perl #128919]');
+ is(0x1p-1076, 1.23516411460311636e-324);
+ is(0x1p-16445, 3.6451995318824746e-4951);
+}
+
# sprintf %a/%A testing is done in sprintf2.t,
# trickier than necessary because of long doubles,
# and because looseness of the spec.
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
my $got;
#local @INC; # local fails on tied @INC
my @old_INC = @INC; # because local doesn't work on tied arrays
- @INC = ('lib', 'lib/Devel', sub { $got = $_[1]; return undef; });
+ @INC = ('lib', 'lib/Devel', sub { $got = $_[1]; return undef; });
foreach my $filename ('/test_require.pm', './test_require.pm',
'../test_require.pm') {
local %INC;
}
{
local @INC = @INC;
- unshift @INC, (\&fake_module)x2;
+ @INC = (\&fake_module)x2;
eval { require "${\'bralbalhablah'}" };
like $@, qr/^Can't locate/,
'require PADTMP passing freed var when @INC has multiple subs';\r
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
- skip_all_if_miniperl('no dynamic loading on miniperl, no Filter::Util::Call');
- skip_all_without_perlio();
+ set_up_inc( qw(. ../lib) );
+ skip_all_if_miniperl(
+ 'no dynamic loading on miniperl, no Filter::Util::Call'
+ );
}
+
+skip_all_without_perlio();
+
use strict;
use Config;
use Filter::Util::Call;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
require Config;
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 29;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
BEGIN {
BEGIN {
chdir 't' if -d 't';
require './test.pl';
- @INC = '../lib';
+ set_up_inc('../lib');
}
# Hack to allow test counts to be specified piecemeal
use tests 2; # First make sure that %! %- %+ do not load extra modules.
map %{"foo::$_"}, qw< ! - + >;
ok !exists $INC{'Errno.pm'}, '$swext::! does not load Errno';
+
ok !exists $INC{'Tie/Hash/NamedCapture.pm'},
'$foo::+ and $foo::- do not load Tie::Hash::NamedCapture';
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 26);
+plan(tests => 28);
{
no warnings 'deprecated';
'* <null> ident'
);
SKIP: {
- skip "Different output on EBCDIC (presumably)", 2 if $::IS_EBCDIC;
+ skip "Different output on EBCDIC (presumably)", 3 if $::IS_EBCDIC;
fresh_perl_is(
qq'"ab}"ax;&\0z\x8Ao}\x82x;', <<gibberish,
Bareword found where operator expected at - line 1, near ""ab}"ax"
{ stderr => 1 },
'gibberish containing &{+z} - used to crash [perl #123753]'
);
+ fresh_perl_is(
+ "\@{\327\n", <<\gibberisi,
+Unrecognized character \xD7; marked by <-- HERE after @{<-- HERE near column 3 at - line 1.
+gibberisi
+ { stderr => 1 },
+ '@ { \327 \n - used to garble output (or fail asan) [perl #128951]'
+ );
}
fresh_perl_is(
'$_ = q-strict.pm-; 1 ? require : die;'
.' print qq-ok\n- if $INC{q-strict.pm-}',
"ok\n",
+ {},
'foo ? require : bar [perl #128307]'
);
+
+like runperl(prog => 'sub ub(){0} ub ub', stderr=>1), qr/Bareword found/,
+ '[perl #126482] Assert failure when mentioning a constant twice in a row';
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
$| = 1;
{ # Check calling STORE
note('Tied variables, calling STORE');
my $sc = 0;
- sub B::TIESCALAR {bless [11], 'B'}
- sub B::FETCH { -(shift->[0]) }
- sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift }
+ # do not use B:: namespace
+ sub BB::TIESCALAR {bless [11], 'BB'}
+ sub BB::FETCH { -(shift->[0]) }
+ sub BB::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift }
my $m;
- tie $m, 'B';
+ tie $m, 'BB';
$m = 100;
is( $sc, 1, 'STORE called when assigning scalar to tied variable' );
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
- require Config;
+ set_up_inc('../lib');
+ require Config;
# Don't bother if there are no quad offsets.
skip_all('no 64-bit file offsets')
if $Config::Config{lseeksize} < 8;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require "./test.pl";
+ set_up_inc(qw(. ../lib));
}
plan( tests => 70 );
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
+ set_up_inc( qw(. ../lib) );
}
plan tests => 310;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
+ set_up_inc( qw(. ../lib) );
}
plan tests => 5;
# -- .robin. <robin@kitsite.com> 2001-03-13
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require "./test.pl";
+ set_up_inc(qw(. ../lib));
}
plan( tests => 67 );
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 23;
$SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
chdir 't' if -d 't';
require './test.pl';
- skip_all_if_miniperl("no dynamic loading on miniperl, no Tie::Hash::NamedCapture");
- plan(tests => 2);
+ skip_all_if_miniperl(
+ "no dynamic loading on miniperl, no Tie::Hash::NamedCapture"
+ );
}
+plan(tests => 2);
+
use strict;
# Test for bug [perl #27839]
BEGIN {
$| = 1;
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
- plan (tests => 192);
+ set_up_inc( '../lib' );
+ plan (tests => 192); # some tests are run in BEGIN block
}
# Test that defined() returns true for magic variables created on the fly,
$Is_MSWin32 ? '.\perl' :
'./perl');
+
sub env_is {
my ($key, $val, $desc) = @_;
undef %Errno::;
delete $INC{"Errno.pm"};
+ delete $::{"!"};
open(FOO, "nonesuch"); # Generate ENOENT
my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
sub FETCH { push @RT12608::G::ISA, "RT12608::H"; "RT12608::Y"; }
}
+
# ^^^^^^^^^ New tests go here ^^^^^^^^^
SKIP: {
if $ENV{PERL_VALGRIND} || $Is_VMS;
$PATH = $ENV{PATH};
+ $SYSTEMROOT = $ENV{SYSTEMROOT} if exists $ENV{SYSTEMROOT}; # win32
$PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
$ENV{foo} = "bar";
%ENV = ();
$ENV{PATH} = $PATH;
+ $ENV{SYSTEMROOT} = $SYSTEMROOT if defined $SYSTEMROOT;
$ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0;
if ($Is_MSWin32) {
is `set foo 2>NUL`, "";
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib lib ../dist/base/lib);
require "./test.pl";
+ set_up_inc( qw(. ../lib lib ../dist/base/lib) );
}
use strict;
eval 'sub AUTOLOAD { "ok ", shift, "\n"; }';
ok(1);
-# Bug ID 20010902.002
+# Bug ID 20010902.002 (#7609)
is(
eval q[
my $x = 'x'; # Lexical or package variable, 5.6.1 panics.
is($w, '');
}
-# [ID 20020305.025] PACKAGE::SUPER doesn't work anymore
+# [ID 20020305.025 (#8788)] PACKAGE::SUPER doesn't work anymore
package main;
our @X;
qr/^Can't call method "squeak" on unblessed reference/,
'method call on \*typeglob';
*stdout2 = *STDOUT; # stdout2 now stringifies as *main::STDOUT
-sub IO::Handle::self { $_[0] }
+ sub IO::Handle::self { $_[0] }
# This used to stringify the glob:
is *stdout2->self, (\*stdout2)->self,
'*glob->method is equiv to (\*glob)->method';
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 17;
#!./perl
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
sub foo {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
+plan tests => 1;
+
use strict;
eval 'my $_';
like $@, qr/^Can't use global \$_ in "my" at /;
-done_testing();
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 48;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 24;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
if (pack("d", 1) =~ /^[\x80\10]\x40/) {
skip_all("VAX float cannot do infinity");
}
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc('../lib');
}
package main;
-require './test.pl';
plan( tests => 14 );
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib); # ../lib needed for test.deparse
require "./test.pl";
+ set_up_inc(qw(. ../lib)); # ../lib needed for test.deparse
}
plan tests => 35;
BEGIN {
chdir 't' if -d 't';
- @INC = qw '../lib ../cpan/version/lib';
require './test.pl';
+ set_up_inc(qw '../lib ../cpan/version/lib');
}
# XXX remove this later -- dagolden, 2010-01-13
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
-plan tests => 29;
+plan tests => 33;
$x='banana';
$x=~/.a/g;
$x=~/.a/g;
is(f(pos($x)), 4, "matching again, pos() next leaves off at offset 4");
-# Is pos() set inside //g? (bug id 19990615.008)
+# Is pos() set inside //g? (bug id 19990615.008 (#874))
$x = "test string?"; $x =~ s/\w/pos($x)/eg;
is($x, "0123 5678910?", "pos() set inside //g");
'no assertion failure when getting pos clobbers ref with undef';
}
}
+
+{
+ # RT # 127518
+ my $x = "\N{U+10000}abc";
+ my %expected = (
+ chars => { length => 4, pos => 2 },
+ bytes => { length => 7, pos => 5 },
+ );
+ my %observed;
+ $observed{chars}{length} = length($x);
+ $x =~ m/a/g;
+ $observed{chars}{pos} = pos($x);
+
+ {
+ use bytes;
+ $observed{bytes}{length} = length($x);
+ $observed{bytes}{pos} = pos($x);
+ }
+
+ is( $observed{chars}{length}, $expected{chars}{length},
+ "Got expected length in chars");
+ is( $observed{chars}{pos}, $expected{chars}{pos},
+ "Got expected pos in chars");
+ is( $observed{bytes}{length}, $expected{bytes}{length},
+ "Got expected length in bytes");
+ is( $observed{bytes}{pos}, $expected{bytes}{pos},
+ "Got expected pos in bytes");
+}
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
+ set_up_inc(qw(. ../lib));
}
use strict qw(refs subs);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
# This calculation ought to be within 0.001 of the right answer.
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ require './test.pl';
+ set_up_inc( qw(. ../lib) );
}
use strict;
use warnings;
-BEGIN {
- require './test.pl';
- plan( tests => 12 );
-}
+plan( tests => 12 );
use vars qw{ @warnings $sub $warn };
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib .);
- require Config; import Config;
require "./test.pl";
+ set_up_inc( qw(../lib .) );
+ require Config; import Config;
require "./loc_tools.pl";
}
BEGIN {
chdir "t" if -d "t";
- @INC = qw(. ../lib);
+ require "./test.pl";
+ set_up_inc( qw(. ../lib) );
}
use strict;
use Config;
-require "./test.pl";
-
-
my $reps = 100_000; # How many times to try rand each time.
# May be changed, but should be over 500.
# The more the better! (But slower.)
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib', '.');
+ require './test.pl';
+ set_up_inc('../lib', '.');
}
# Avoid using eq_array below as it uses .. internally.
-require './test.pl';
use Config;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
{ # [perl #118651]
# test that readdir doesn't modify errno on successfully reaching the end of the list
# in scalar context, POSIX requires that readdir() not modify errno on end-of-directory
+
my @s;
ok(opendir(OP, "op"), "opendir op");
$! = 0;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require "./test.pl";
- plan(tests => 28);
+ set_up_inc(qw(. ../lib));
}
+plan(tests => 28);
+
use strict;
sub gcd {
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
+ set_up_inc( qw(. ../lib) );
}
use strict qw(refs subs);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc( '../lib' );
}
-require './test.pl';
plan(tests => 48);
# compile time
'(...)x... in void context in list (via scalar comma)');
-# perlbug 20011113.110 works in 5.6.1, broken in 5.7.2
+# perlbug 20011113.110 (#7902) works in 5.6.1, broken in 5.7.2
{
my $x= [("foo") x 2];
- is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110]' );
+ is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110 (#7902)]' );
}
# [perl #35885]
chdir 't' if -d 't';
require './test.pl';
-@INC = 'lib';
+set_up_inc( 'lib' );
use strict;
BEGIN {
chdir 't' if -d 't';
require './test.pl';
- @INC="../lib";
+ set_up_inc( qw(../lib) );
}
use strict;
my $nonfile = tempfile();
-@INC = qw(Perl Rules);
-
# The tests for ' ' and '.h' never did fail, but previously the error reporting
# code would read memory before the start of the SV's buffer
$WARN = '';
local @INC = @INC;
- unshift @INC, "lib\0invalid";
+ set_up_inc( "lib\0invalid" );
eval { require "unknown.pm" };
like $WARN, qr{^Invalid \\0 character in \@INC entry for require: lib\\0invalid at }, 'nul warning';
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
my $copy = $prog;
$copy =~ s/8/$eight/gm;
$copy =~ s/9/$nine/gm;
- fresh_perl_is($copy, "pass", "",
+ fresh_perl_is($copy, "pass", {},
"first pattern $eight$eight, second $nine$nine");
}
}
##
chdir 't' if -d 't';
-@INC = '../lib';
require './test.pl';
+set_up_inc('../lib');
$|=1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_without_config('d_setpgrp');
}
set_up_inc('../lib');
}
-no warnings "illegalproto";
+use warnings;
+use strict;
our $a = 123;
our $z;
-sub t000 ($a) { $a || "z" }
-is prototype(\&t000), "\$a", "(\$a) interpreted as protoype when not enabled";
-is &t000(456), 123, "(\$a) not signature when not enabled";
-is $a, 123;
+{
+ no warnings "illegalproto";
+ sub t000 ($a) { $a || "z" }
+ is prototype(\&t000), "\$a", "(\$a) interpreted as protoype when not enabled";
+ is &t000(456), 123, "(\$a) not signature when not enabled";
+ is $a, 123;
+}
no warnings "experimental::signatures";
use feature "signatures";
is $a, 123;
eval "#line 8 foo\nsub t024 (\$a =) { }";
-is $@, "Optional parameter lacks default expression at foo line 8\.\n";
+is $@,
+ qq{Optional parameter lacks default expression at foo line 8, near "=) "\n};
sub t025 ($ = undef) { $a // "z" }
is prototype(\&t025), undef;
is $a, 123;
eval "#line 8 foo\nsub t030 (\$a = 222, \$b) { }";
-is $@, "Mandatory parameter follows optional parameter at foo line 8\.\n";
+is $@, qq{Mandatory parameter follows optional parameter at foo line 8, near "\$b) "\n};
eval "#line 8 foo\nsub t031 (\$a = 222, \$b = 333, \$c, \$d) { }";
-is $@, "Mandatory parameter follows optional parameter at foo line 8\.\n";
+is $@, <<EOF;
+Mandatory parameter follows optional parameter at foo line 8, near "\$c,"
+Mandatory parameter follows optional parameter at foo line 8, near "\$d) "
+EOF
sub t034 (@abc) { join("/", @abc).";".scalar(@abc) }
is prototype(\&t034), undef;
is $a, 123;
eval "#line 8 foo\nsub t136 (\@abc = 222) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n};
eval "#line 8 foo\nsub t137 (\@abc =) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n};
sub t035 (@) { $a }
is prototype(\&t035), undef;
is $a, 123;
eval "#line 8 foo\nsub t138 (\@ = 222) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n};
eval "#line 8 foo\nsub t139 (\@ =) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n};
sub t039 (%abc) { join("/", map { $_."=".$abc{$_} } sort keys %abc) }
is prototype(\&t039), undef;
is $a, 123;
eval "#line 8 foo\nsub t140 (\%abc = 222) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n};
eval "#line 8 foo\nsub t141 (\%abc =) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n};
sub t040 (%) { $a }
is prototype(\&t040), undef;
is $a, 123;
eval "#line 8 foo\nsub t142 (\% = 222) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "222) "\n};
eval "#line 8 foo\nsub t143 (\% =) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{A slurpy parameter may not have a default value at foo line 8, near "=) "\n};
sub t041 ($a, @b) { $a.";".join("/", @b) }
is prototype(\&t041), undef;
is $a, 123;
eval "#line 8 foo\nsub t059 (\@a, \$b) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n};
eval "#line 8 foo\nsub t060 (\@a, \$b = 222) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n};
eval "#line 8 foo\nsub t061 (\@a, \@b) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@b) "\n};
eval "#line 8 foo\nsub t062 (\@a, \%b) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "%b) "\n};
eval "#line 8 foo\nsub t063 (\@, \$b) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n};
eval "#line 8 foo\nsub t064 (\@, \$b = 222) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n};
eval "#line 8 foo\nsub t065 (\@, \@b) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@b) "\n};
eval "#line 8 foo\nsub t066 (\@, \%b) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "%b) "\n};
eval "#line 8 foo\nsub t067 (\@a, \$) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "\$) "\n};
eval "#line 8 foo\nsub t068 (\@a, \$ = 222) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n};
eval "#line 8 foo\nsub t069 (\@a, \@) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@) "\n};
eval "#line 8 foo\nsub t070 (\@a, \%) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\%) "\n};
eval "#line 8 foo\nsub t071 (\@, \$) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "\$) "\n};
eval "#line 8 foo\nsub t072 (\@, \$ = 222) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "222) "\n};
eval "#line 8 foo\nsub t073 (\@, \@) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\@) "\n};
eval "#line 8 foo\nsub t074 (\@, \%) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Multiple slurpy parameters not allowed at foo line 8, near "\%) "\n};
eval "#line 8 foo\nsub t075 (\%a, \$b) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n};
eval "#line 8 foo\nsub t076 (\%, \$b) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "\$b) "\n};
eval "#line 8 foo\nsub t077 (\$a, \@b, \$c) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "\$c) "\n};
eval "#line 8 foo\nsub t078 (\$a, \%b, \$c) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, qq{Slurpy parameter not last at foo line 8, near "\$c) "\n};
eval "#line 8 foo\nsub t079 (\$a, \@b, \$c, \$d) { }";
-is $@, "Slurpy parameter not last at foo line 8\.\n";
+is $@, <<EOF;
+Slurpy parameter not last at foo line 8, near "\$c,"
+Slurpy parameter not last at foo line 8, near "\$d) "
+EOF
sub t080 ($a,,, $b) { $a.$b }
is prototype(\&t080), undef;
is $a, 123;
eval "#line 8 foo\nsub t082 (, \$a) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{syntax error at foo line 8, near "(,"\n};
eval "#line 8 foo\nsub t083 (,) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, qq{syntax error at foo line 8, near "(,"\n};
sub t084($a,$b){ $a.$b }
is prototype(\&t084), undef;
eval "#line 8 foo\nsub t088 (\$ #foo\na) { }";
is $@, "";
+
eval "#line 8 foo\nsub t089 (\$#foo\na) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(\$"\n};
eval "#line 8 foo\nsub t090 (\@ #foo\na) { }";
is $@, "";
eval "#line 8 foo\nsub t091 (\@#foo\na) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(\@"\n};
eval "#line 8 foo\nsub t092 (\% #foo\na) { }";
is $@, "";
eval "#line 8 foo\nsub t093 (\%#foo\na) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+like $@, qr{\A'#' not allowed immediately following a sigil in a subroutine signature at foo line 8, near "\(%"\n};
eval "#line 8 foo\nsub t094 (123) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+like $@, qr{\AA signature parameter must start with '\$', '\@' or '%' at foo line 8, near "\(1"\n};
eval "#line 8 foo\nsub t095 (\$a, 123) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, <<EOF;
+A signature parameter must start with '\$', '\@' or '%' at foo line 8, near ", 1"
+syntax error at foo line 8, near ", 123"
+EOF
-eval "#line 8 foo\nsub t096 (\$a 123) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+eval "#line 8 foo\nno warnings; sub t096 (\$a 123) { }";
+is $@, qq{syntax error at foo line 8, near "\$a 123"\n};
eval "#line 8 foo\nsub t097 (\$a { }) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, <<EOF;
+syntax error at foo line 8, near "\$a { "
+EOF
eval "#line 8 foo\nsub t098 (\$a; \$b) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, <<EOF;
+syntax error at foo line 8, at EOF
+syntax error at foo line 8, near "\$b) "
+EOF
eval "#line 8 foo\nsub t099 (\$\$) { }";
-like $@, qr/\AParse error at foo line 8\.\n/;
+is $@, <<EOF;
+Illegal character following sigil in a subroutine signature at foo line 8, near "(\$"
+syntax error at foo line 8, near "\$\$) "
+EOF
eval "#line 8 foo\nsub t101 (\@_) { }";
like $@, qr/\ACan't use global \@_ in "my" at foo line 8/;
is scalar(@{[ t117(333, 444) ]}), 0;
is scalar(t117(333, 444)), undef;
+sub t145 ($=3) { }
+is scalar(t145()), undef;
+
+{
+ my $want;
+ sub want { $want = wantarray ? "list"
+ : defined(wantarray) ? "scalar" : "void"; 1 }
+
+ sub t144 ($a = want()) { $a }
+ t144();
+ is ($want, "scalar", "default expression is scalar in void context");
+ my $x = t144();
+ is ($want, "scalar", "default expression is scalar in scalar context");
+ () = t144();
+ is ($want, "scalar", "default expression is scalar in list context");
+}
+
+
+# check for default arg code doing nasty things (closures, gotos,
+# modifying @_ etc).
+
+{
+ no warnings qw(closure);
+ use Tie::Array;
+ use Tie::Hash;
+
+ sub t146 ($a = t146x()) {
+ sub t146x { $a = "abc"; 1 }
+ $a;
+ }
+ is t146(), 1, "t146: closure can make new lexical not undef";
+
+ sub t147 ($a = t147x()) {
+ sub t147x { $a = "abc"; pos($a)=1; 1 }
+ is pos($a), undef, "t147: pos magic cleared";
+ $a;
+ }
+ is t147(), 1, "t147: closure can make new lexical not undef and magical";
+
+ sub t148 ($a = t148x()) {
+ sub t148x { $a = []; 1 }
+ $a;
+ }
+ is t148(), 1, "t148: closure can make new lexical a ref";
+
+ sub t149 ($a = t149x()) {
+ sub t149x { $a = 1; [] }
+ $a;
+ }
+ is ref(t149()), "ARRAY", "t149: closure can make new lexical a ref";
+
+ sub t150 ($a = do {@_ = qw(a b c); 1}, $b = 2) {
+ is $a, 1, "t150: a: growing \@_";
+ is $b, "b", "t150: b: growing \@_";
+ }
+ t150();
+
+
+ sub t151 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, $b = 2) {
+ is $a, 1, "t151: a: tied \@_";
+ is $b, "b", "t151: b: tied \@_";
+ }
+ t151();
+
+ sub t152 ($a = t152x(), @b) {
+ sub t152x { @b = qw(a b c); 1 }
+ $a . '-' . join(':', @b);
+ }
+ is t152(), "1-", "t152: closure can make new lexical array non-empty";
+
+ sub t153 ($a = t153x(), %b) {
+ sub t153x { %b = qw(a 10 b 20); 1 }
+ $a . '-' . join(':', sort %b);
+ }
+ is t153(), "1-", "t153: closure can make new lexical hash non-empty";
+
+ sub t154 ($a = t154x(), @b) {
+ sub t154x { tie @b, 'Tie::StdArray'; @b = qw(a b c); 1 }
+ $a . '-' . join(':', @b);
+ }
+ is t154(), "1-", "t154: closure can make new lexical array tied";
+
+ sub t155 ($a = t155x(), %b) {
+ sub t155x { tie %b, 'Tie::StdHash'; %b = qw(a 10 b 20); 1 }
+ $a . '-' . join(':', sort %b);
+ }
+ is t155(), "1-", "t155: closure can make new lexical hash tied";
+
+ sub t156 ($a = do {@_ = qw(a b c); 1}, @b) {
+ is $a, 1, "t156: a: growing \@_";
+ is "@b", "b c", "t156: b: growing \@_";
+ }
+ t156();
+
+ sub t157 ($a = do {@_ = qw(a b c); 1}, %b) {
+ is $a, 1, "t157: a: growing \@_";
+ is join(':', sort %b), "b:c", "t157: b: growing \@_";
+ }
+ t157();
+
+ sub t158 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, @b) {
+ is $a, 1, "t158: a: tied \@_";
+ is "@b", "b c", "t158: b: tied \@_";
+ }
+ t158();
+
+ sub t159 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, %b) {
+ is $a, 1, "t159: a: tied \@_";
+ is join(':', sort %b), "b:c", "t159: b: tied \@_";
+ }
+ t159();
+
+ # see if we can handle the equivalent of @a = ($a[1], $a[0])
+
+ sub t160 ($s, @a) {
+ sub t160x {
+ @a = qw(x y);
+ t160(1, $a[1], $a[0]);
+ }
+ # encourage recently-freed SVPVs to be realloced with new values
+ my @pad = qw(a b);
+ join ':', $s, @a;
+ }
+ is t160x(), "1:y:x", 'handle commonality in slurpy array';
+
+ # see if we can handle the equivalent of %h = ('foo', $h{foo})
+
+ sub t161 ($s, %h) {
+ sub t161x {
+ %h = qw(k1 v1 k2 v2);
+ t161(1, k1 => $h{k2}, k2 => $h{k1});
+ }
+ # encourage recently-freed SVPVs to be realloced with new values
+ my @pad = qw(a b);
+ join ' ', $s, map "($_,$h{$_})", sort keys %h;
+ }
+ is t161x(), "1 (k1,v2) (k2,v1)", 'handle commonality in slurpy hash';
+
+ # see if we can handle the equivalent of ($a,$b) = ($b,$a)
+ # Note that for non-signatured subs, my ($a,$b) = @_ already fails the
+ # equivalent of this test too, since I skipped pessimising it
+ # (90ce4d057857) as commonality in this case is rare and contrived,
+ # as the example below shows. DAPM.
+ sub t162 ($a, $b) {
+ sub t162x {
+ ($a, $b) = qw(x y);
+ t162($b, $a);
+ }
+ "$a:$b";
+ }
+ {
+ local $::TODO = q{can't handle commonaility};
+ is t162x(), "y:x", 'handle commonality in scalar parms';
+ }
+}
+
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= "@_" };
+ is eval q{sub ($x,$x) { $x}->(1,2)}, 2, "duplicate sig var names";
+ like $w, qr/^"my" variable \$x masks earlier declaration in same scope/,
+ "masking warning";
+}
+
+
+
use File::Spec::Functions;
my $keywords_file = catfile(updir,'regen','keywords.pl');
open my $kh, $keywords_file
chomp(my $word = $');
# $y should be an error after $x=foo. The exact error we get may
# differ if this is __END__ or s or some other special keyword.
- eval 'sub ($x = ' . $word . ', $y) {}';
- local $::TODO = 'does not work yet'
- if $word =~ /^(?:chmod|chown|die|exec|glob|kill|mkdir|print
- |printf|return|reverse|select|setpgrp|sort|split
- |system|unlink|utime|warn)\z/x;
+ eval 'no warnings; sub ($x = ' . $word . ', $y) {}';
isnt $@, "", "$word does not swallow trailing comma";
}
}
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ require "./test.pl";
+ set_up_inc( qw(. ../lib) );
}
-require "./test.pl";
plan( tests => 4 );
use strict;
set_up_inc('../lib');
}
use warnings;
-plan(tests => 195);
+plan(tests => 196);
# these shouldn't hang
{
{
sub routine { "one", "two" };
@a = sort(routine(1));
- cmp_ok("@a",'eq',"one two",'bug id 19991001.003');
+ cmp_ok("@a",'eq',"one two",'bug id 19991001.003 (#1549)');
}
my ($r1,$r2,@a);
our @g;
@g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0];
- is "$r1-@g", "$r2-1 2 3", "inplace sort of global";
+ is "$$r1-$$r2-@g", "1-1-1 2 3", "inplace sort of global";
@a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0];
- is "$r1-@a", "$r2-a b c", "inplace sort of lexical";
+ is "$$r1-$$r2-@a", "a-a-a b c", "inplace sort of lexical";
@g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0];
- is "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global";
+ is "$$r1-$$r2-@g", "3-3-3 2 1", "inplace reversed sort of global";
@g = (2,3,1);
$r1 = \$g[1]; @g = sort { $a<$b?1:$a>$b?-1:0 } @g; $r2 = \$g[0];
- is "$r1-@g", "$r2-3 2 1", "inplace custom sort of global";
+ is "$$r1-$$r2-@g", "3-3-3 2 1", "inplace custom sort of global";
sub mysort { $b cmp $a };
@a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0];
- is "$r1-@a", "$r2-c b a", "inplace sort with function of lexical";
+ is "$$r1-$$r2-@a", "c-c-c b a", "inplace sort with function of lexical";
use Tie::Array;
my @t;
no warnings 'void';
my @m; push @m, 0 for 1 .. 1024; $#m; @m = sort @m;
::pass("in-place sorting segfault");
+
+ # RT #39358 - array should be preserved during sort
+
+ {
+ my @aa = qw(b c a);
+ my @copy;
+ @aa = sort { @copy = @aa; $a cmp $b } @aa;
+ is "@aa", "a b c", "RT 39358 - aa";
+ is "@copy", "b c a", "RT 39358 - copy";
+ }
+
+ # RT #128340: in-place sort incorrectly preserves element lvalue identity
+
+ @a = (5, 4, 3);
+ my $r = \$a[2];
+ @a = sort { $a <=> $b } @a;
+ $$r = "z";
+ is ("@a", "3 4 5", "RT #128340");
+
}
# Test optimisations of reversed sorts. As we now guarantee stability by
}
-# Bug 7567 - an array shouldn't be modifiable while it's being
-# sorted in-place.
-{
- eval { @a=(1..8); @a = sort { @a = (0) } @a; };
-
- $fail_msg = q(Modification of a read-only value attempted);
- cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567');
- eval { @a=1..3 };
- is $@, "", 'abrupt scope exit turns off readonliness';
-}
# I commented out this TODO test because messing with FREEd scalars on the
# stack can have all sorts of strange side-effects, not made safe by eval
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
$| = 1;
is( j(splice(@a,-3,-2,2)), j(7), 'replace first 7 with a 2, negative offset, negative length, return value is 7');
is( j(@a), j(1,2,7,3), '... array has 1,2,7,3');
-# Bug 20000223.001 - no test for splice(@array). Destructive test!
+# Bug 20000223.001 (#2196) - no test for splice(@array). Destructive test!
is( j(splice(@a)), j(1,2,7,3), 'bare splice empties the array, return value is the array');
is( j(@a), '', 'array is empty');
# Tests 11 and 12:
-# [ID 20010711.005] in Tie::Array, SPLICE ignores context, breaking SHIFT
+# [ID 20010711.005 (#7265)] in Tie::Array, SPLICE ignores context, breaking SHIFT
my $foo;
is("@ary", "1 20 300 4000 50000 4000 300 20 1");
is($cnt, scalar(@ary));
-@ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016
-$cnt = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016
+@ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 (#5088)
+$cnt = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 (#5088)
ok(@ary == 2 &&
$ary[0] eq "\xFF" && $ary[1] eq "\xFD" &&
$ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}");
}
{
- # bug id 20000427.003
+ # bug id 20000427.003 (#3173)
use warnings;
use strict;
my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20";
{
- # bug id 20000426.003
+ # bug id 20000426.003 (#3166)
my ($a, $b, $c) = split(/\x40/, $s);
ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a);
}
{
- # 20001205.014
+ # 20001205.014 (#4844)
my $a = "ABC\x{263A}";
BEGIN {
chdir 't' if -d 't';
require './test.pl';
- skip_all_if_miniperl("no dynamic loading on miniperl, no File::Spec (used by charnames)");
- plan(tests => 145);
}
+skip_all_if_miniperl("no dynamic loading on miniperl, no File::Spec (used by charnames)");
+plan(tests => 145);
+
{
# check the special casing of split /\s/ and unicode
use charnames qw(:full);
BEGIN {
chdir 't' if -d 't';
- @INC = qw '../lib ../cpan/version/lib';
+ require './test.pl';
+ set_up_inc(qw '../lib ../cpan/version/lib');
}
use warnings;
use version;
use Config;
use strict;
-require './test.pl';
+
my @tests = ();
my ($template, $data, $result, $comment, $w, $x, $evalData, $n, $p);
# No %Config.
my $Is_Ultrix_VAX = $^O eq 'ultrix' && `uname -m` =~ /^VAX$/;
+# The most generic VAX catcher.
+my $Is_VAX_Float = (pack("d", 1) =~ /^[\x80\x10]\x40/);
+
our $IS_EBCDIC = $::IS_EBCDIC; # Solely to avoid the 'used once' warning
our $IS_ASCII = $::IS_ASCII; # Solely to avoid the 'used once' warning
$data =~ s/([eE])\-101$/${1}-56/; # larger exponents
$result =~ s/([eE])\-102$/${1}-57/; # " "
}
- if ($Is_VMS_VAX || $Is_Ultrix_VAX) {
+ if ($Is_VMS_VAX || $Is_Ultrix_VAX || $Is_VAX_Float) {
# VAX DEC C 5.3 at least since there is no
# ccflags =~ /float=ieee/ on VAX.
# AXP is unaffected whether or not it is using ieee.
my $osv = exists $Config{osvers} ? $Config{osvers} : "0";
my $archname = $Config{archname};
# >comment skip: all<
- if ($os =~ /\ball\b/i) {
- $skip = 1;
- } elsif ($os =~ /\b$^O(?::(\S+))?\b/i) {
+ # >comment skip: solaris<
+ # >comment skip: x86_64-linux-ld<
+ if ($os =~ /\b(?:all|\Q$^O\E|\Q$archname\E)\b/i) {
+ $skip = 1;
+ } elsif ($os =~ /\b\Q$^O\E(?::(\S+))\b/i) {
# We can have the $^O followed by an optional condition.
# The condition, if present, can be one of:
- # (1) a regex between slashes...
- # tested as a regex against $Config{archname}
- # (2) starts with a digit...
+ # (1) starts with a digit...
# the first pair of dot-separated digits is
- # tested against $Config{osvers}
- # (3) tested as literal string against $Config{archname}
+ # tested numerically against $Config{osvers}
+ # (2) otherwise...
+ # tested as a \b/i regex against $Config{archname}
my $cond = $1;
- if ($cond =~ m{^/(.+)/$}) {
- # >comment skip: solaris:/86/<
- my $vsr = $1;
- $skip = $archname =~ /$vsr/;
- } elsif ($cond =~ /^\d/) {
+ if ($cond =~ /^\d/) {
# >comment skip: hpux:10.20<
my $vsn = $cond;
# Only compare on the the first pair of digits, as numeric
$skip = $vsn ? ($osv <= $vsn ? 1 : 0) : 1;
} else {
# >comment skip: netbsd:vax-netbsd<
- $skip = $cond eq $archname;
+ $skip = $archname =~ /\b\Q$cond\E\b/i;
}
}
$skip and $comment =~ s/$/, failure expected on $^O $osv $archname/;
ok(1, join ' ', grep length, ">$result<", $comment);
}
elsif ($skip) {
- ok(1, "skip $comment");
+ SKIP: { skip($comment, 1) }
}
elsif ($y eq ">$result<") # Some C libraries always give
{ # three-digit exponent
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
# We'll run 12 extra tests (see below) if $Q is false.
print "# nvsize = $Config{nvsize}\n";
print "# nv_preserves_uv_bits = $Config{nv_preserves_uv_bits}\n";
print "# d_quad = $Config{d_quad}\n";
+print "# uselongdouble = " . ($Config{uselongdouble} // 'undef') . "\n";
if ($Config{nvsize} == 8 &&
(
# IEEE-754 64-bit ("double precision"), the most common out there
[ '%a', '0.25', '0x1p-2' ],
[ '%a', '0.75', '0x1.8p-1' ],
[ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
- [ '%a', '-1', '-0x0p+0' ],
+ [ '%a', '-1', '-0x1p+0' ],
[ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb85p+1' ],
[ '%a', '0.1', '0x1.999999999999999999999999998p-4' ],
[ '%a', '1/7', '0x1.249249249249249249249249248p-3' ],
print "# no hexfloat tests\n";
}
-plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat + 12;
-
use strict;
use Config;
# Used to mangle PL_sv_undef
fresh_perl_like(
'print sprintf "xxx%n\n"; print undef',
- qr/Modification of a read-only value attempted at - line 1\./,
+ qr/Modification of a read-only value attempted at\b/,
{ switches => [ '-w' ] },
q(%n should not be able to modify read-only constants),
);
ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
next;
}
- unless ($ok) {
+ if (!$ok && $result =~ /\./ && $expected =~ /\./) {
# It seems that there can be difference in the last bits:
# [perl #122578]
# got "0x1.5bf0a8b14576ap+1"
SKIP: {
# [perl #127183] Non-canonical hexadecimal floats are parsed prematurely
+ # IEEE 754 64-bit
skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits}, not 53", 3)
unless $Config{nv_preserves_uv_bits} == 53;
"non-canonical form");
}
}
+
+# These are IEEE 754 64-bit subnormals (formerly known as denormals).
+# Keep these as strings so that non-IEEE-754 don't trip over them.
+my @subnormals = (
+ [ '1e-320', '%a', '0x1.fap-1064' ],
+ [ '1e-321', '%a', '0x1.94p-1067' ],
+ [ '1e-322', '%a', '0x1.4p-1070' ],
+ [ '1e-323', '%a', '0x1p-1073' ],
+ [ '1e-324', '%a', '0x0p+0' ], # underflow
+ [ '3e-320', '%a', '0x1.7b8p-1062' ],
+ [ '3e-321', '%a', '0x1.2f8p-1065' ],
+ [ '3e-322', '%a', '0x1.e8p-1069' ],
+ [ '3e-323', '%a', '0x1.8p-1072' ],
+ [ '3e-324', '%a', '0x1p-1074' ], # the smallest possible value
+ [ '7e-320', '%a', '0x1.bacp-1061' ],
+ [ '7e-321', '%a', '0x1.624p-1064' ],
+ [ '7e-322', '%a', '0x1.1cp-1067' ],
+ [ '7e-323', '%a', '0x1.cp-1071' ],
+ [ '7e-324', '%a', '0x1p-1074' ], # the smallest possible value, again
+ [ '3e-320', '%.4a', '0x1.7b80p-1062' ],
+ [ '3e-321', '%.4a', '0x1.2f80p-1065' ],
+ [ '3e-322', '%.4a', '0x1.e800p-1069' ],
+ [ '3e-323', '%.4a', '0x1.8000p-1072' ],
+ [ '3e-324', '%.4a', '0x1.0000p-1074' ],
+ [ '3e-320', '%.1a', '0x1.8p-1062' ],
+ [ '3e-321', '%.1a', '0x1.3p-1065' ],
+ [ '3e-322', '%.1a', '0x1.ep-1069' ],
+ [ '3e-323', '%.1a', '0x1.8p-1072' ],
+ [ '3e-324', '%.1a', '0x1.0p-1074' ],
+ [ '0x1.fffffffffffffp-1022', '%a', '0x1.fffffffffffffp-1022' ],
+ [ '0x0.fffffffffffffp-1022', '%a', '0x1.ffffffffffffep-1023' ],
+ [ '0x0.7ffffffffffffp-1022', '%a', '0x1.ffffffffffffcp-1024' ],
+ [ '0x0.3ffffffffffffp-1022', '%a', '0x1.ffffffffffff8p-1025' ],
+ [ '0x0.1ffffffffffffp-1022', '%a', '0x1.ffffffffffffp-1026' ],
+ [ '0x0.0ffffffffffffp-1022', '%a', '0x1.fffffffffffep-1027' ],
+ );
+
+SKIP: {
+ # [rt.perl.org #128843]
+ skip("non-IEEE-754-non-64-bit", scalar @subnormals + 34)
+ unless ($Config{nvsize} == 8 &&
+ $Config{nv_preserves_uv_bits} == 53 &&
+ ($Config{doublekind} == 3 ||
+ $Config{doublekind} == 4));
+
+ for my $t (@subnormals) {
+ # Note that "0x1p+2" is not considered numeric,
+ # since neither is "0x12", hence the eval.
+ my $s = sprintf($t->[1], eval $t->[0]);
+ is($s, $t->[2], "subnormal @$t got $s");
+ }
+
+ # [rt.perl.org #128888]
+ is(sprintf("%a", 1.03125), "0x1.08p+0");
+ is(sprintf("%.1a", 1.03125), "0x1.0p+0");
+ is(sprintf("%.0a", 1.03125), "0x1p+0", "[rt.perl.org #128888]");
+
+ # [rt.perl.org #128889]
+ is(sprintf("%.*a", -1, 1.03125), "0x1.08p+0", "[rt.perl.org #128889]");
+
+ # [rt.perl.org #128890]
+ is(sprintf("%a", 0x1.18p+0), "0x1.18p+0");
+ is(sprintf("%.1a", 0x1.08p+0), "0x1.0p+0");
+ is(sprintf("%.1a", 0x1.18p+0), "0x1.2p+0", "[rt.perl.org #128890]");
+ is(sprintf("%.1a", 0x1.28p+0), "0x1.2p+0");
+ is(sprintf("%.1a", 0x1.38p+0), "0x1.4p+0");
+ is(sprintf("%.1a", 0x1.48p+0), "0x1.4p+0");
+ is(sprintf("%.1a", 0x1.58p+0), "0x1.6p+0");
+ is(sprintf("%.1a", 0x1.68p+0), "0x1.6p+0");
+ is(sprintf("%.1a", 0x1.78p+0), "0x1.8p+0");
+ is(sprintf("%.1a", 0x1.88p+0), "0x1.8p+0");
+ is(sprintf("%.1a", 0x1.98p+0), "0x1.ap+0");
+ is(sprintf("%.1a", 0x1.a8p+0), "0x1.ap+0");
+ is(sprintf("%.1a", 0x1.b8p+0), "0x1.cp+0");
+ is(sprintf("%.1a", 0x1.c8p+0), "0x1.cp+0");
+ is(sprintf("%.1a", 0x1.d8p+0), "0x1.ep+0");
+ is(sprintf("%.1a", 0x1.e8p+0), "0x1.ep+0");
+ is(sprintf("%.1a", 0x1.f8p+0), "0x2.0p+0");
+
+ is(sprintf("%.1a", 0x1.10p+0), "0x1.1p+0");
+ is(sprintf("%.1a", 0x1.17p+0), "0x1.1p+0");
+ is(sprintf("%.1a", 0x1.19p+0), "0x1.2p+0");
+ is(sprintf("%.1a", 0x1.1fp+0), "0x1.2p+0");
+
+ is(sprintf("%.2a", 0x1.fffp+0), "0x2.00p+0");
+ is(sprintf("%.2a", 0xf.fffp+0), "0x2.00p+3");
+
+ # [rt.perl.org #128893]
+ is(sprintf("%020a", 1.5), "0x0000000000001.8p+0");
+ is(sprintf("%020a", -1.5), "-0x000000000001.8p+0", "[rt.perl.org #128893]");
+ is(sprintf("%+020a", 1.5), "+0x000000000001.8p+0", "[rt.perl.org #128893]");
+ is(sprintf("% 020a", 1.5), " 0x000000000001.8p+0", "[rt.perl.org #128893]");
+ is(sprintf("%20a", -1.5), " -0x1.8p+0");
+ is(sprintf("%+20a", 1.5), " +0x1.8p+0");
+ is(sprintf("% 20a", 1.5), " 0x1.8p+0");
+}
+
+# x86 80-bit long-double tests for
+# rt.perl.org #128843, #128888, #128889, #128890, #128893, #128909
+SKIP: {
+ skip("non-80-bit-long-double", 17)
+ unless ($Config{uselongdouble} &&
+ ($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
+ ($Config{longdblkind} == 3 ||
+ $Config{longdblkind} == 4));
+
+ {
+ # The last normal for this format.
+ is(sprintf("%a", eval '0x1p-16382'), "0x8p-16385", "[rt.perl.org #128843]");
+
+ # The subnormals cause "exponent underflow" warnings,
+ # but that is not why we are here.
+ local $SIG{__WARN__} = sub {
+ die "$0: $_[0]" unless $_[0] =~ /exponent underflow/;
+ };
+
+ is(sprintf("%a", eval '0x1p-16383'), "0x4p-16382", "[rt.perl.org #128843]");
+ is(sprintf("%a", eval '0x1p-16384'), "0x2p-16382", "[rt.perl.org #128843]");
+ is(sprintf("%a", eval '0x1p-16385'), "0x1p-16382", "[rt.perl.org #128843]");
+ is(sprintf("%a", eval '0x1p-16386'), "0x8p-16386", "[rt.perl.org #128843]");
+ is(sprintf("%a", eval '0x1p-16387'), "0x4p-16386", "[rt.perl.org #128843]");
+ }
+ is(sprintf("%.0a", 1.03125), "0x8p-3", "[rt.perl.org #128888]");
+ is(sprintf("%.*a", -1, 1.03125), "0x8.4p-3", "[rt.perl.org #128889]");
+ is(sprintf("%.1a", 0x8.18p+0), "0x8.2p+0", "[rt.perl.org #128890]");
+ is(sprintf("%020a", -1.5), "-0x0000000000000cp-3", "[rt.perl.org #128893]");
+ is(sprintf("%+020a", 1.5), "+0x0000000000000cp-3", "[rt.perl.org #128893]");
+ is(sprintf("% 020a", 1.5), " 0x0000000000000cp-3", "[rt.perl.org #128893]");
+ is(sprintf("%a", 1.9999999999999999999), "0xf.fffffffffffffffp-3");
+ is(sprintf("%.3a", 1.9999999999999999999), "0x1.000p+1", "[rt.perl.org #128909]");
+ is(sprintf("%.2a", 1.9999999999999999999), "0x1.00p+1");
+ is(sprintf("%.1a", 1.9999999999999999999), "0x1.0p+1");
+ is(sprintf("%.0a", 1.9999999999999999999), "0x1p+1");
+}
+
+# quadmath tests for rt.perl.org #128843
+SKIP: {
+ skip "need quadmath", 7, unless $Config{usequadmath};
+
+ is(sprintf("%a", eval '0x1p-16382'), '0x1p-16382'); # last normal
+
+ local $SIG{__WARN__} = sub {
+ die "$0: $_[0]" unless $_[0] =~ /exponent underflow/;
+ };
+
+ is(sprintf("%a", eval '0x1p-16383'), '0x1p-16383');
+ is(sprintf("%a", eval '0x1p-16384'), '0x1p-16384');
+
+ is(sprintf("%a", eval '0x1p-16491'), '0x1p-16491');
+ is(sprintf("%a", eval '0x1p-16492'), '0x1p-16492');
+ is(sprintf("%a", eval '0x1p-16493'), '0x1p-16493'); # last denormal
+
+ is(sprintf("%a", eval '0x1p-16494'), '0x1p-16494'); # underflow
+}
+
+done_testing();
BEGIN {
chdir "t" if -d "t";
- @INC = qw(. ../lib);
+ require "./test.pl";
+ set_up_inc( qw(. ../lib) );
}
# Test srand.
use strict;
-require "./test.pl";
plan(tests => 10);
# Generate a load of random numbers.
my $hires;
BEGIN {
chdir 't' if -d 't';
- @INC = ('.', '../lib');
+ require './test.pl';
+ set_up_inc('.', '../lib');
$hires = eval 'use Time::HiResx "time"; 1';
}
-require './test.pl';
-
skip_all("Win32 miniperl has no socket select")
if $^O eq "MSWin32" && is_miniperl();
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib);
+ require "./test.pl";
+ set_up_inc( qw(../lib) );
}
-BEGIN { require "./test.pl"; }
-
plan( tests => 54 );
# Used to segfault (bug #15479)
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl'; # for which_perl() etc
+ set_up_inc('../lib');
}
use Config;
unlink $tmpfile or print "# unlink failed: $!\n";
-# bug id 20011101.069
+# bug id 20011101.069 (#7861)
my @r = \stat($Curdir);
is(scalar @r, 13, 'stat returns full 13 elements');
SKIP: {
skip "No lstat", 2 unless $Config{d_lstat};
- # bug id 20020124.004
+ # bug id 20020124.004 (#8334)
# If we have d_lstat, we should have symlink()
my $linkname = 'stat-' . rand =~ y/.//dr;
my $target = $Perl;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
watchdog(10);
$_ = 'FGF';
study;
- ok(!/G.F$/, 'bug 20010618.006');
- ok(!/[F]F$/, 'bug 20010618.006');
+ ok(!/G.F$/, 'bug 20010618.006 (#7126)');
+ ok(!/[F]F$/, 'bug 20010618.006 (#7126)');
}
{
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests=>211;
}
is("@p", "1 8");
-sub keeze : lvalue { keys %__ }
-%__ = ("a","b");
-keeze = 64;
-is Hash::Util::bucket_ratio(%__), '1/64', 'keys assignment through lvalue sub';
-eval { (keeze) = 64 };
-like $@, qr/^Can't modify keys in list assignment at /,
- 'list assignment to keys through lv sub is forbidden';
-sub akeeze : lvalue { keys @_ }
-eval { (akeeze) = 64 };
-like $@, qr/^Can't modify keys on array in list assignment at /,
- 'list assignment to keys @_ through lv sub is forbidden';
-
-# Bug 20001223.002: split thought that the list had only one element
+SKIP: {
+ skip "no Hash::Util on miniperl", 3, if is_miniperl;
+ require Hash::Util;
+ sub Hash::Util::bucket_ratio (\%);
+
+ sub keeze : lvalue { keys %__ }
+ %__ = ("a","b");
+ keeze = 64;
+ is Hash::Util::bucket_ratio(%__), '1/64', 'keys assignment through lvalue sub';
+ eval { (keeze) = 64 };
+ like $@, qr/^Can't modify keys in list assignment at /,
+ 'list assignment to keys through lv sub is forbidden';
+ sub akeeze : lvalue { keys @_ }
+ eval { (akeeze) = 64 };
+ like $@, qr/^Can't modify keys on array in list assignment at /,
+ 'list assignment to keys @_ through lv sub is forbidden';
+}
+
+# Bug 20001223.002 (#5005): split thought that the list had only one element
@ary = qw(4 5 6);
sub lval1 : lvalue { $ary[0]; }
sub lval2 : lvalue { $ary[1]; }
is ($result, 'bar', "RT #41550");
}
-SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes';
+SKIP: {
+ skip 'no attributes.pm', 1 unless eval 'require attributes';
fresh_perl_is(<<'----', <<'====', {}, "lvalue can not be set after definition. [perl #68758]");
use warnings;
our $x;
use Config;
-plan tests => 132;
+plan tests => 138;
# 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
'delete local on nonexistent env var');
}
+# defined
+leak(2, 0, sub { defined *{"!"} }, 'defined *{"!"}');
+leak(2, 0, sub { defined *{"["} }, 'defined *{"["}');
+leak(2, 0, sub { defined *{"-"} }, 'defined *{"-"}');
+sub def_bang { defined *{"!"}; delete $::{"!"} }
+def_bang;
+leak(2, 0, \&def_bang,'defined *{"!"} vivifying GV');
+leak(2, 0, sub { defined *{"["}; delete $::{"["} },
+ 'defined *{"["} vivifying GV');
+sub def_neg { defined *{"-"}; delete $::{"-"} }
+def_neg;
+leak(2, 0, \&def_neg, 'defined *{"-"} vivifying GV');
+
# Fatal warnings
my $f = "use warnings FATAL =>";
my $all = "$f 'all';";
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
- plan( tests => 8 );
+ set_up_inc('../lib');
}
+plan( tests => 8 );
+
use strict;
# first, with delete
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 48;
}
{
- # bug id 20001004.006
+ # bug id 20001004.006 (#4380)
open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ;
local $/;
}
{
- # bug id 20001004.007
+ # bug id 20001004.007 (#4381)
open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ;
my $a = <$fh>;
}
{
- # bug id 20010519.003
+ # bug id 20010519.003 (#7015)
BEGIN {
use vars qw($has_fcntl);
}
{
- # bug 20010526.004
+ # bug 20010526.004 (#7041)
use warnings;
{
- # Bug ID 20010730.010
+ # Bug ID 20010730.010 (#7387)
my $i = 0;
'Assigning to ${^TAINT} fails');
{
- # bug 20011111.105
+ # bug 20011111.105 (#7897)
my $re1 = qr/x$TAINT/;
is_tainted($re1);
SKIP: {
skip "system {} has different semantics on Win32", 1 if $Is_MSWin32;
- # bug 20010221.005
+ # bug 20010221.005 (#5882)
local $ENV{PATH} .= $TAINT;
eval { system { "echo" } "/arg0", "arg1" };
like($@, qr/^Insecure \$ENV/);
todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22
if $Is_VMS;
- # bug 20020208.005 plus some single arg exec/system extras
+ # bug 20020208.005 (#8465) plus some single arg exec/system extras
violates_taint(sub { exec $TAINT, $TAINT }, 'exec');
violates_taint(sub { exec $TAINT $TAINT }, 'exec');
violates_taint(sub { exec $TAINT $TAINT, $TAINT }, 'exec');
}
{
- # [ID 20020704.001] taint propagation failure
+ # [ID 20020704.001 (#10026)] taint propagation failure
use re 'taint';
$TAINT =~ /(.*)/;
is_tainted(my $foo = $1);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc( '../lib' );
$| = 1;
skip_all_without_config('useithreads');
'no crash when deleting $::{INC} in thread'
);
-fresh_perl_is(<<'CODE', 'ok', 'no crash modifying extended array element');
+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;
#
chdir 't' if -d 't';
-@INC = '../lib';
require './test.pl';
+set_up_inc('../lib');
$|=1;
2
########
-# [20020716.007] - nested FETCHES
+# [20020716.007 (#10080)] - nested FETCHES
sub F1::TIEARRAY { bless [], 'F1' }
sub F1::FETCH { 1 }
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
- plan (tests => 345);
}
+plan (tests => 345);
+
use strict;
use warnings;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
my %seen;
}
{
- # [ID 20020713.001] chomp($data=<tied_fh>)
+ # [ID 20020713.001 (#10048)] chomp($data=<tied_fh>)
local *TEST;
tie *TEST, 'CHOMP';
my $data;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 72;
use utf8;
-plan tests => 164;
+plan tests => 166;
# Test this first before we extend the stack with other operations.
# This caused an asan failure due to a bad write past the end of the stack.
is $wc, 1, '/r warns just once';
}
-# perlbug [ID 20000511.005]
+# perlbug [ID 20000511.005 (#3237)]
$_ = 'fred';
/([a-z]{2})/;
$1 =~ tr/A-Z//;
# rt.perl.org 36622. Perl didn't like a y/// at end of file. No trailing
# newline allowed.
-fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], '');
+fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], '', {}, 'RT #36622 y/// at end of file');
{ # [perl #38293] chr(65535) should be allowed in regexes
ok(1, "tr///d on glob does not assert");
}
+{ # [perl #128734
+ my $string = chr utf8::unicode_to_native(0x00e0);
+ $string =~ tr/\N{U+00e0}/A/;
+ is($string, "A", 'tr// of \N{U+...} works for upper-Latin1');
+ my $string = chr utf8::unicode_to_native(0x00e1);
+ $string =~ tr/\N{LATIN SMALL LETTER A WITH ACUTE}/A/;
+ is($string, "A", 'tr// of \N{name} works for upper-Latin1');
+}
+
1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan 6;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
$|=1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl'; require './charset_tools.pl';
+ require './test.pl';
+ set_up_inc('../lib');
+ require './charset_tools.pl';
}
plan tests => 6;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
-
- plan(tests => 99);
+ set_up_inc('../lib');
}
+plan(tests => 99);
+
use strict;
# Two hashes one with all 8-bit possible keys (initially), other
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
$SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN };
- require "./test.pl"; require "./charset_tools.pl";
+ require "./test.pl";
+ set_up_inc( qw(. ../lib) );
+ require "./charset_tools.pl";
}
$DOWARN = 1; # enable run-time warnings now
}
{
- # bug id 20000323.056
+ # bug id 20000323.056 (#2641)
- is( "\x{41}", +v65, 'bug id 20000323.056');
- is( "\x41", +v65, 'bug id 20000323.056');
- is( "\x{c8}", +v200, 'bug id 20000323.056');
- is( "\xc8", +v200, 'bug id 20000323.056');
- is( "\x{221b}", +v8731, 'bug id 20000323.056');
+ is( "\x{41}", +v65, 'bug id 20000323.056 (#2641)');
+ is( "\x41", +v65, 'bug id 20000323.056 (#2641)');
+ is( "\x{c8}", +v200, 'bug id 20000323.056 (#2641)');
+ is( "\xc8", +v200, 'bug id 20000323.056 (#2641)');
+ is( "\x{221b}", +v8731, 'bug id 20000323.056 (#2641)');
}
# See if the things Camel-III says are true: 29..33
# Chapter 28, pp671
ok(v5.6.0 lt v5.7.0, "v5.6.0 lt v5.7.0");
-# part of 20000323.059
+# part of 20000323.059 (#2644)
is(v200, chr(200), "v200 eq chr(200)" );
is(v200, +v200, "v200 eq +v200" );
is(v200, eval( "v200"), 'v200 eq "v200"' );
{
no warnings 'deprecated'; # These are above IV_MAX on 32 bit machines
- # [ID 20010902.001] check if v-strings handle full UV range or not
+ # [ID 20010902.001 (#7608)] check if v-strings handle full UV range or not
if ( $Config{'uvsize'} >= 4 ) {
is( sprintf("%vd", eval 'v2147483647.2147483648'), '2147483647.2147483648', 'v-string > IV_MAX[32-bit]' );
is( sprintf("%vd", eval 'v3141592653'), '3141592653', 'IV_MAX < v-string < UV_MAX[32-bit]');
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
require Config;
skip_all('no Errno')
unless eval 'use Errno qw(EINVAL); 1';
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
($a) = scalar context('S');
{
- # [ID 20020626.011] incorrect wantarray optimisation
+ # [ID 20020626.011 (#9998)] incorrect wantarray optimisation
sub simple { wantarray ? 1 : 2 }
sub inline {
my $a = wantarray ? simple() : simple();
BEGIN {
chdir 't' if -d 't';
- @INC = "../lib";
require "./test.pl";
+ set_up_inc('../lib');
}
plan(26);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc('../lib');
}
# This file has been placed in t/opbasic to indicate that it should not use
# Okay, so that wasn't very challenging. Let's go Unicode.
{
- # bug id 20000819.004
+ # bug id 20000819.004 (#3761)
$_ = $dx = "\x{10f2}";
s/($dx)/$dx$1/;
{
- ok($_ eq "$dx$dx","bug id 20000819.004, back");
+ ok($_ eq "$dx$dx","bug id 20000819.004 (#3761), back");
}
$_ = $dx = "\x{10f2}";
s/($dx)/$1$dx/;
{
- ok($_ eq "$dx$dx","bug id 20000819.004, front");
+ ok($_ eq "$dx$dx","bug id 20000819.004 (#3761), front");
}
$dx = "\x{10f2}";
$_ = "\x{10f2}\x{10f2}";
s/($dx)($dx)/$1$2/;
{
- ok($_ eq "$dx$dx","bug id 20000819.004, front and back");
+ ok($_ eq "$dx$dx","bug id 20000819.004 (#3761), front and back");
}
}
{
- # bug id 20000901.092
+ # bug id 20000901.092 (#4184)
# test that undef left and right of utf8 results in a valid string
my $a;
$a .= "\x{1ff}";
- ok($a eq "\x{1ff}", "bug id 20000901.092, undef left");
+ ok($a eq "\x{1ff}", "bug id 20000901.092 (#4184), undef left");
$a .= undef;
- ok($a eq "\x{1ff}", "bug id 20000901.092, undef right");
+ ok($a eq "\x{1ff}", "bug id 20000901.092 (#4184), undef right");
}
{
- # ID 20001020.006
+ # ID 20001020.006 (#4484)
"x" =~ /(.)/; # unset $2
# Without the fix this 5.7.0 would croak:
# Modification of a read-only value attempted at ...
eval {"$2\x{1234}"};
- ok(!$@, "bug id 20001020.006, left");
+ ok(!$@, "bug id 20001020.006 (#4484), left");
# For symmetry with the above.
eval {"\x{1234}$2"};
- ok(!$@, "bug id 20001020.006, right");
+ ok(!$@, "bug id 20001020.006 (#4484), right");
*pi = \undef;
# This bug existed earlier than the $2 bug, but is fixed with the same
# patch. Without the fix this 5.7.0 would also croak:
# Modification of a read-only value attempted at ...
eval{"$pi\x{1234}"};
- ok(!$@, "bug id 20001020.006, constant left");
+ ok(!$@, "bug id 20001020.006 (#4484), constant left");
# For symmetry with the above.
eval{"\x{1234}$pi"};
- ok(!$@, "bug id 20001020.006, constant right");
+ ok(!$@, "bug id 20001020.006 (#4484), constant right");
}
sub beq { use bytes; $_[0] eq $_[1]; }
#
# call:: subroutine and method handling
# expr:: expressions: e.g. $x=1, $foo{bar}[0]
+# func:: perl functions, e.g. func::sort::...
# loop:: structural code like for, while(), etc
# regex:: regular expressions
# string:: string handling
code => '$y = $x--', # scalar context so not optimised to --$x
},
+
+ 'func::sort::num' => {
+ desc => 'plain numeric sort',
+ setup => 'my (@a, @b); @a = reverse 1..10;',
+ code => '@b = sort { $a <=> $b } @a',
+ },
+ 'func::sort::num_block' => {
+ desc => 'codeblock numeric sort',
+ setup => 'my (@a, @b); @a = reverse 1..10;',
+ code => '@b = sort { $a + 1 <=> $b + 1 } @a',
+ },
+ 'func::sort::num_fn' => {
+ desc => 'function numeric sort',
+ setup => 'sub f { $a + 1 <=> $b + 1 } my (@a, @b); @a = reverse 1..10;',
+ code => '@b = sort f @a',
+ },
+ 'func::sort::str' => {
+ desc => 'plain string sort',
+ setup => 'my (@a, @b); @a = reverse "a".."j";',
+ code => '@b = sort { $a cmp $b } @a',
+ },
+ 'func::sort::str_block' => {
+ desc => 'codeblock string sort',
+ setup => 'my (@a, @b); @a = reverse "a".."j";',
+ code => '@b = sort { ($a . "") cmp ($b . "") } @a',
+ },
+ 'func::sort::str_fn' => {
+ desc => 'function string sort',
+ setup => 'sub f { ($a . "") cmp ($b . "") } my (@a, @b); @a = reverse "a".."j";',
+ code => '@b = sort f @a',
+ },
+
+ 'func::sort::num_inplace' => {
+ desc => 'plain numeric sort in-place',
+ setup => 'my @a = reverse 1..10;',
+ code => '@a = sort { $a <=> $b } @a',
+ },
+ 'func::sort::num_block_inplace' => {
+ desc => 'codeblock numeric sort in-place',
+ setup => 'my @a = reverse 1..10;',
+ code => '@a = sort { $a + 1 <=> $b + 1 } @a',
+ },
+ 'func::sort::num_fn_inplace' => {
+ desc => 'function numeric sort in-place',
+ setup => 'sub f { $a + 1 <=> $b + 1 } my @a = reverse 1..10;',
+ code => '@a = sort f @a',
+ },
+ 'func::sort::str_inplace' => {
+ desc => 'plain string sort in-place',
+ setup => 'my @a = reverse "a".."j";',
+ code => '@a = sort { $a cmp $b } @a',
+ },
+ 'func::sort::str_block_inplace' => {
+ desc => 'codeblock string sort in-place',
+ setup => 'my @a = reverse "a".."j";',
+ code => '@a = sort { ($a . "") cmp ($b . "") } @a',
+ },
+ 'func::sort::str_fn_inplace' => {
+ desc => 'function string sort in-place',
+ setup => 'sub f { ($a . "") cmp ($b . "") } my @a = reverse "a".."j";',
+ code => '@a = sort f @a',
+ },
+
+
'loop::block' => {
desc => 'empty basic loop',
- setup => ';',
+ setup => '',
code => '{1;}',
},
use warnings;
use strict;
-plan 2250;
+plan 2256;
use B ();
{
concat => 0,
});
+
+{
+ no warnings 'experimental::signatures';
+ use feature 'signatures';
+
+ my @a;
+ test_opcount(0, 'signature default expressions get optimised',
+ sub ($s = $a[0]) {},
+ {
+ aelem => 0,
+ aelemfast_lex => 1,
+ });
+}
+
+# in-place sorting
+
+{
+ local our @global = (3,2,1);
+ my @lex = qw(a b c);
+
+ test_opcount(0, 'in-place sort of global',
+ sub { @global = sort @global; 1 },
+ {
+ rv2av => 1,
+ aassign => 0,
+ });
+
+ test_opcount(0, 'in-place sort of lexical',
+ sub { @lex = sort @lex; 1 },
+ {
+ padav => 1,
+ aassign => 0,
+ });
+
+ test_opcount(0, 'in-place reversed sort of global',
+ sub { @global = sort { $b <=> $a } @global; 1 },
+ {
+ rv2av => 1,
+ aassign => 0,
+ });
+
+
+ test_opcount(0, 'in-place custom sort of global',
+ sub { @global = sort { $a<$b?1:$a>$b?-1:0 } @global; 1 },
+ {
+ rv2av => 1,
+ aassign => 0,
+ });
+
+ sub mysort { $b cmp $a };
+ test_opcount(0, 'in-place sort with function of lexical',
+ sub { @lex = sort mysort @lex; 1 },
+ {
+ padav => 1,
+ aassign => 0,
+ });
+
+
+}
-Encode cpan/Encode/Byte/Makefile.PL 54f446297d614331ef3f51e8310faff27cc44f90
-Encode cpan/Encode/encoding.pm 90ea1844e5ae863a17dd40ac6a0f27f438db9c1f
-Encode cpan/Encode/t/enc_data.t e8b94d651a6519e186a2b74245f0002c4bb62160
-Encode cpan/Encode/t/enc_eucjp.t 9d73fce7d5ae83036be546d1603262baffd68cdb
-Encode cpan/Encode/t/enc_module.t aad4fcde7389ad55731206f62284dadf21ffe274
-Encode cpan/Encode/t/enc_utf8.t 7d1c9a4260c0c6b263eff30539e591c417e602a9
-Encode cpan/Encode/t/encoding.t ed051c17c92510713b24217c22384815088834a8
-Encode cpan/Encode/t/jperl.t 584a3813e7bc680ee6ec1d54253bbf861bda8215
+CPAN cpan/CPAN/lib/App/Cpan.pm 3cef68c2a44a4996b432bc25622e3a544a188aa5
+CPAN cpan/CPAN/lib/CPAN.pm 4616a44963045f7bd07bb7f8e5f99bbd789af4e5
+CPAN cpan/CPAN/scripts/cpan 22610ed0301d48a269d1739afd2f7f84359d956f
+Digest cpan/Digest/Digest.pm 43f7f544cb11842b2f55c73e28930da50774e081
ExtUtils::Constant cpan/ExtUtils-Constant/t/Constant.t a0369c919e216fb02767a637666bb4577ad79b02
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/basic.t b7ee8691baf37197bf4249534f429fcf28f5cedf
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/XS.pm 27aaa6acefd4223b57de74299314c19891ed17bc
File::Path cpan/File-Path/lib/File/Path.pm fd8ce4420a0c113d3f47dd3223859743655c1da8
File::Path cpan/File-Path/t/Path_win32.t 94b9276557ce7f80b91f6fd9bfa7a0cd9bf9683e
-Module::Metadata cpan/Module-Metadata/t/extract-package.t ddb0a96a6bd0c1593c5654d4ac4449c1a64f6953
-Module::Metadata cpan/Module-Metadata/t/metadata.t ed2fa6cb370800830a826f19c4f012ff622e6aab
+IO-Compress cpan/IO-Compress/bin/zipdetails 381ba2a6ae5bd21c8d2e994316e3e13f2f0a4f41
+IO-Compress cpan/IO-Compress/lib/Compress/Zlib.pm 0f93fb368d1d6af6f461b86304e8aabe0472754d
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm 3acbcf5538e036a1b7907eedf038badf38254d71
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm ed1c8835f3c3cb333b1ff5d4d517695ac2569f6a
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm 75a361c5032bf602cd55d2b52a9fc6dee3f966ee
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Base.pm 490ddf3f073a6d1a9b508a06e870709d19932d6f
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Base/Common.pm 46dcd7effb81737a5e3aaa322d2b7404a36666e4
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Bzip2.pm 4fc4bc90f9566eeecb0b6f3fe3b59443ed838378
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Deflate.pm 729f52133f69df0d4e83f1561c1a4a9b18c00753
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Gzip.pm 26654883fe0e4224e1d86c8d7d8cd11d75505075
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm f8cc94ebbbf50310d7fbd9c4addf1619646e8e7a
+IO-Compress cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm 19ba3e84de766613f53e29de4f76b46ed50b780c
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Zip.pm db0231d4dea78b8400db6ea7b65ac9ef95ead319
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm e810575fb4ef2a4a2e26ab528484061eb822f508
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm 65fe46cd7b9fdfd54bdfc4635829fb302d0d6d30
+IO-Compress cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm d80925cae9d1f26c526e898a70d6d4052749b217
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm 784c7c313969d869a59118d327895e0b60f1decc
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm 5ed1888ebf365026460873e37c7db8bf7655b1a0
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm f427dff7fb2cb55f7ee04adc20986cc3ae32e84c
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm c51ae0e7524891d82634309353700cc802583b7e
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm 18b7d32dfa4eee9c11bdd8a98e68bcd00040e082
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/Base.pm 821b0445d3edfa5761e7a7935cd80b2b35e22017
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm 7dd2eaf1727fa77e184c7cb2d6513f396e57a3e8
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm 7490524bf3714621bb3292574d0f97212f2538bd
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm c75aa1ec1f2a6138ef9ae660771fb2cac8be6931
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm 8f30a77bcda7123300ef5a8d02c2160ebb72f013
+IO-Compress cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm 321a55011a1f11fe73b005e33942eb27fed6d046
+JSON::PP cpan/JSON-PP/bin/json_pp a7b8de6c201ef177ee82624ee4ca6a47cc1a3b4f
+JSON::PP cpan/JSON-PP/lib/JSON/PP.pm c8762a306740d0b32c099faf7118f2c1a391d9db
+Locale::Maketext::Simple cpan/Locale-Maketext-Simple/lib/Locale/Maketext/Simple.pm 57ed38905791a17c150210cd6f42ead22a7707b6
+Memoize cpan/Memoize/Memoize.pm 902092ff91cdec9c7b4bd06202eb179e1ce26ca2
Pod::Checker cpan/Pod-Checker/t/pod/contains_bad_pod.xr 73538fd80dfe6e19ad561fe034009b44460208f6
Pod::Checker cpan/Pod-Checker/t/pod/selfcheck.t 8ce3cfd38e4b9bcf5bc7fe7f2a14195e49aed7d8
Pod::Checker cpan/Pod-Checker/t/pod/testcmp.pl a0cd5c8eca775c7753f4464eee96fa916e3d8a16
Pod::Checker cpan/Pod-Checker/t/pod/testpchk.pl b2072c7f4379fd050e15424175d7cac5facf5b3b
-Pod::Perldoc cpan/Pod-Perldoc/lib/Pod/Perldoc.pm fe0bc906fb74b69cfd3fb289316ba669d770d465
Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util.pm e479a29c6b66ac5cbbde4ef2296afaab6c4635a6
Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util/XS.pm cbc38838d32fd213ae7b37ac38e30195355be3b9
Scalar-List-Utils cpan/Scalar-List-Utils/lib/Scalar/Util.pm 14a20075dfb9a4ef33b99115ed6f43e6d1a15f9b
Scalar-List-Utils cpan/Scalar-List-Utils/ListUtil.xs 362a247c65878265fd8acae607b207400628ef3b
Socket cpan/Socket/Socket.pm 98e38176d745c38282907f391c077298f5a3d0ba
Socket cpan/Socket/Socket.xs edd4fed212785f11c5c2095a75941dad27d586d9
+Sys::Syslog cpan/Sys-Syslog/Syslog.pm 1cbcaaf58302bf803570546d8ced83190d3e5581
+Test::Harness cpan/Test-Harness/bin/prove 9b2866928cb1125de2c68f9773b25723e02c54c0
+Test::Harness cpan/Test-Harness/lib/App/Prove.pm a312bbbc97860d5051f06056eb30b985b15ee57c
+Test::Harness cpan/Test-Harness/lib/App/Prove/State.pm f4f7d11878eae1fd81d9c3d82097ddfd43b679a1
+Test::Harness cpan/Test-Harness/lib/App/Prove/State/Result.pm 374f5be770e2709c744ddf77927b73ab0f644219
+Test::Harness cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm d3a2ef3916946e0880ffd00356b3ed0feb589029
+Test::Harness cpan/Test-Harness/lib/TAP/Base.pm 38c1bbc33e1e28919dd905ee7f416c2f1cd2014b
+Test::Harness cpan/Test-Harness/lib/TAP/Formatter/Base.pm 92783e20c15f982a25025c1fd7dc512071aa2671
+Test::Harness cpan/Test-Harness/lib/TAP/Formatter/Color.pm f4f02b5a4f8f11c0e9fa95d06e9bc8f14a172555
+Test::Harness cpan/Test-Harness/lib/TAP/Formatter/Console.pm 36fec1e9ca70e359cf1cf110cbdf86040686e635
+Test::Harness cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm 579df1507c22c5a6c8116943ba7b084dd557a2a3
+Test::Harness cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm 98f620cadecbe7529b62addf35e16be72b066bcf
+Test::Harness cpan/Test-Harness/lib/TAP/Formatter/File.pm 531f646edd5d5768a02728be5c3c1786df17a328
+Test::Harness cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm cb8b1dd0039381c41b11ba186ed25969fd33b654
+Test::Harness cpan/Test-Harness/lib/TAP/Formatter/Session.pm ce57cb909e8e9b1a8263939da1b4eac6ac5df6e5
+Test::Harness cpan/Test-Harness/lib/TAP/Harness.pm dbbeef74569163d00c8befccf9f2670bafa2dc2f
+Test::Harness cpan/Test-Harness/lib/TAP/Harness/Env.pm 7743d40504d23867fe5f6b3967f7c907c530074f
+Test::Harness cpan/Test-Harness/lib/TAP/Object.pm 19b27d7e30f6e69c3ffaec939418978ba7b0bc7c
+Test::Harness cpan/Test-Harness/lib/TAP/Parser.pm a97c90c41959194ad828511a2b5f6ad068fd2f23
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm bf32f2c834f5242af1db2b5f02419451e87c3b68
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Grammar.pm 2626f555bcf238e4c6a5a0e07eb016f38520d705
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Iterator.pm 6b2729f8883718683b0a2d7cd75d734501360e7b
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm c4ebe427ef24bfbcfcf74459cb74249bf84ec92a
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm 43c08c6ba2a2e599f503cfec086f8ac9b2b8a8f1
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm f28ccf211ebdb527b558a83d6969d96ba13414af
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm 561ba7be34786134f70b67e73e604de1c934f9bb
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm 7417eede2c1554b94dfbbbce5a90dc6e4d8bbbe6
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result.pm be74c62222a90404d2d6586f77a4f66bafee2879
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm 89a3c49f5b03501813b5a6133ca2ca3fa25f8648
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm e49dde84304dc1a034fd1a5c38f18bed99c1b4d4
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm cf334e85a8e77fe6f830744f70e4c9c1a24c36a5
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b1587f903cc7937190789b1de8bdf20d6e30ff28
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm dff1422b7cc8ea0c24aedef020fc2266144eb1ea
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm 0959ff5602d340f92be31f01ee2f890028784a8d
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm 8491bba7a07568374cafd8fc40cb08d9b4458e9b
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm 7dc7b96d882dce5e20696305705f4f0e7462d8bc
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm 1f64e8390990ad99eea3d0fb202487ba973e9a2d
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm 471ea7d1db535364dd86ab106771c652742c0c05
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm 3d7ee9db8277b50fcebcf239898a8023791b8654
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm 1c04e88f45719f92961821d9ed65e80800986893
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/Source.pm c820d95e2a4797893eb717c07b72742e6e0a1542
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm b25f8e7d1a9f2215175618a989df39d78a878df5
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm 5f542b39c98ebe3ee6d906e38b8944abbac5188b
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm 6aa5762461cb06f3db57d13de0fc771d5563c871
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm edc91794e1fbefbbf8e919658fe7a5bbd7c84916
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm 809d6d6779c2aed829a9a087ecb219fbcc7fbfb5
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm d01e1e2a87733ab45f387e34803f821ed184e5cc
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm 76771092dd2b87a2adb7ff20b7ae77cbae7d0563
+Test::Harness cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm bf1fbfff9720330886651f183959a5db56daeea0
+Test::Harness cpan/Test-Harness/lib/Test/Harness.pm da2d76ba673372da129060c9d0adb8cf0d91f9f7
autodie cpan/autodie/t/mkdir.t 9e70d2282a3cc7d76a78bf8144fccba20fb37dac
+base dist/base/lib/base.pm 9575442273694d41c8e86cb1d86fa1935a07c8a8
+bignum cpan/bignum/lib/bigint.pm b901044cb5ecd8b331495769f547350da5d4ed60
+bignum cpan/bignum/lib/bignum.pm 9903bb25a330e0af73016000c0fba147bb990afd
+bignum cpan/bignum/lib/bigrat.pm b8fcffd8e60bfa9f32ccb9ab8c0fa5726d6392f8
+bignum cpan/bignum/lib/Math/BigFloat/Trace.pm 1ec133b0c03687fd621cc35946c465c66e38127a
+bignum cpan/bignum/lib/Math/BigInt/Trace.pm 3e1cc7726c55f9d5f4db6e5ec41c5fd266fcb289
version cpan/version/lib/version.pm a032a751524bdd07a93c945d2a1703abe7ad8ef0
+Encode cpan/Encode/Encode.xs dba310bf3d362b1ade421b1a741875511d84809a
Class::Tiny::Antlers
Classic::Perl
clearerr(3)
+clock(3)
Clone
closedir(2)
connect(2)
Data::Structure::Util
Data::Types
Data::Util
+Date::Parse
Date::Pcalc
DateTime
DB_File(3)
Log::Message::Simple
lseek(2)
LWP::ConsoleLogger
+Mail::Mailer
Mail::Send
+Mail::Sendmail
Mail::SpamAssassin
man(5)
man(7)
pod/perlce.pod Verbatim line length including indents exceeds 79 by 3
pod/perldebguts.pod Verbatim line length including indents exceeds 79 by 27
pod/perldebtut.pod Verbatim line length including indents exceeds 79 by 3
+pod/perldelta.pod Apparent broken link 1
pod/perldtrace.pod Verbatim line length including indents exceeds 79 by 7
pod/perlgit.pod ? Should you be using F<...> or maybe L<...> instead of 1
pod/perlgit.pod Verbatim line length including indents exceeds 79 by 1
last SKIP;
}
- sub note {
- my $message = shift;
+ sub _note {
+ my ($andle, $message) = @_;
chomp $message;
- print $message =~ s/^/# /mgr;
- print "\n";
+ print $andle $message =~ s/^/# /mgr;
+ print $andle "\n";
return;
}
+ sub note { unshift @_, \*STDOUT; goto &_note }
+
+ sub diag { unshift @_, \*STDERR; goto &_note }
+
END {
if ($planned && $planned != $current_test) {
print STDERR
}
ok(@diagnostics == $thankful_diagnostics, $output);
if (@diagnostics) {
- note(join "", @diagnostics,
+ diag(join "", @diagnostics,
"See end of this test output for your options on silencing this");
}
: "were $were_count_files files";
my $message = <<EOF;
-HOW TO GET THIS .t TO PASS
+HOW TO GET ${\__FILE__} TO PASS
There $were_count_files that had new potential problems identified.
Some of them may be real, and some of them may be false positives because
and change the count of known potential problems to -1.
EOF
- note($message);
+ diag($message);
} elsif (%files_with_fixes) {
- note(<<EOF
+ diag(<<EOF
To teach this test script that the potential problems have been fixed,
$how_to
EOF
BEGIN {
chdir 't' if -d 't';
- @INC = qw '../lib ../dist/if';
require './test.pl';
require './loc_tools.pl';
+ set_up_inc('../lib', '../dist/if');
}
use strict;
my $utf8_locale;
my @charsets = qw(a d u aa);
-if (! is_miniperl() && locales_enabled('LC_CTYPE')) {
+my $locales_ok = eval { locales_enabled('LC_CTYPE'); 1 };
+if (! is_miniperl() && $locales_ok) {
require POSIX;
my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // "";
if ($current_locale eq 'C') {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
require Config; import Config;
skip_all_if_miniperl("no dynamic loading on miniperl, no Encode nor POSIX");
if ($^O eq 'dec_osf') {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 1;
BEGIN {
chdir 't' if -d 't';
- @INC = qw '../lib ../ext/re';
require './test.pl';
+ set_up_inc(qw '../lib ../ext/re');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.','../ext/re');
require Config; import Config;
require './test.pl'; require './charset_tools.pl';
require './loc_tools.pl';
+ set_up_inc('../lib', '.', '../ext/re');
+}
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
skip_all_without_unicode_tables();
-}
-plan tests => 796; # Update this when adding/deleting tests.
+plan tests => 799; # Update this when adding/deleting tests.
run_tests() unless caller;
/.*a.*b.*c.*[de]/;
',"Timeout",{},"Test Perl 73464")
}
+
+ { # [perl #128686], crashed the the interpreter
+ my $AE = chr utf8::unicode_to_native(0xC6);
+ my $ae = chr utf8::unicode_to_native(0xE6);
+ my $re = qr/[$ae\s]/i;
+ ok($AE !~ $re, '/[\xE6\s]/i doesn\'t match \xC6 when not in UTF-8');
+ utf8::upgrade $AE;
+ ok($AE =~ $re, '/[\xE6\s]/i matches \xC6 when in UTF-8');
+ }
+
+ { # [perl #126606 crashed the interpreter
+ no warnings 'deprecated';
+ like("sS", qr/\N{}Ss|/i, "\N{} with empty branch alternation works");
+ }
+
} # End of sub run_tests
1;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib .);
require './test.pl';
require './charset_tools.pl';
+ set_up_inc(qw '../lib .');
skip_all_if_miniperl("miniperl can't load Tie::Hash::NamedCapture, need for %+ and %-");
}
}
{
- my $message = 'bug id 20001008.001';
+ my $message = 'bug id 20001008.001 (#4407)';
my $strasse = "stra" . uni_to_native("\337") . "e";
my @x = ("$strasse 138", "$strasse 138");
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
require './test.pl';
+ set_up_inc('../lib', '.');
if ($^O eq 'dec_osf') {
skip_all("$^O cannot handle this test");
}
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
require './test.pl';
+ set_up_inc( '../lib', '.' );
skip_all_if_miniperl("miniperl can't load Tie::Hash::NamedCapture, need for %+ and %-");
}
sub run_tests {
like("A \x{263a} B z C", qr/A . B (??{ "z" }) C/,
- "Match UTF-8 char in presence of (??{ }); Bug 20000731.001");
+ "Match UTF-8 char in presence of (??{ }); Bug 20000731.001 (#3600)");
{
no warnings 'uninitialized';
- ok(undef =~ /^([^\/]*)(.*)$/, "Used to cause a SEGV; Bug 20001021.005");
+ ok(undef =~ /^([^\/]*)(.*)$/, "Used to cause a SEGV; Bug 20001021.005 (#4492)");
}
{
- my $message = 'bug id 20001008.001';
+ my $message = 'bug id 20001008.001 (#4407)';
my @x = ("stra\337e 138", "stra\337e 138");
for (@x) {
{
# Fist half of the bug.
- my $message = 'HEBREW ACCENT QADMA matched by .*; Bug 20001028.003';
+ my $message = 'HEBREW ACCENT QADMA matched by .*; Bug 20001028.003 (#4536)';
my $X = chr (1448);
ok(my ($Y) = $X =~ /(.*)/, $message);
is($Y, v1448, $message);
is(length $Y, 1, $message);
# Second half of the bug.
- $message = 'HEBREW ACCENT QADMA in replacement; Bug 20001028.003';
+ $message = 'HEBREW ACCENT QADMA in replacement; Bug 20001028.003 (#4536)';
$X = '';
$X =~ s/^/chr(1488)/e;
is(length $X, 1, $message);
}
{
- my $message = 'Repeated s///; Bug 20001108.001';
+ my $message = 'Repeated s///; Bug 20001108.001 (#4631)';
my $X = "Szab\x{f3},Bal\x{e1}zs";
my $Y = $X;
$Y =~ s/(B)/$1/ for 0 .. 3;
}
{
- my $message = 's/// on UTF-8 string; Bug 20000517.001';
+ my $message = 's/// on UTF-8 string; Bug 20000517.001 (#3253)';
my $x = "\x{100}A";
$x =~ s/A/B/;
is($x, "\x{100}B", $message);
{
# The original bug report had 'no utf8' here but that was irrelevant.
- my $message = "Don't dump core; Bug 20010306.008";
+ my $message = "Don't dump core; Bug 20010306.008 (#5982)";
my $a = "a\x{1234}";
like($a, qr/\w/, $message); # used to core dump.
}
{
- my $message = '/g in scalar context; Bug 20010410.006';
+ my $message = '/g in scalar context; Bug 20010410.006 (#6796)';
for my $rx ('/(.*?)\{(.*?)\}/csg',
'/(.*?)\{(.*?)\}/cg',
'/(.*?)\{(.*?)\}/sg',
{
# Amazingly vertical tabulator is the same in ASCII and EBCDIC.
for ("\n", "\t", "\014", "\r") {
- unlike($_, qr/[[:print:]]/, sprintf "\\%03o not in [[:print:]]; Bug 20010619.003", ord $_);
+ unlike($_, qr/[[:print:]]/, sprintf "\\%03o not in [[:print:]]; Bug 20010619.003 (#7131)", ord $_);
}
for (" ") {
- like($_, qr/[[:print:]]/, "'$_' in [[:print:]]; Bug 20010619.003");
+ like($_, qr/[[:print:]]/, "'$_' in [[:print:]]; Bug 20010619.003 (#7131)");
}
}
{
- # [ID 20010814.004] pos() doesn't work when using =~m// in list context
+ # [ID 20010814.004 (#7526)] pos() doesn't work when using =~m// in list context
$_ = "ababacadaea";
my $a = join ":", /b./gc;
my $b = join ":", /a./gc;
my $c = pos;
- is("$a $b $c", 'ba:ba ad:ae 10', "pos() works with () = m//; Bug 20010814.004");
+ is("$a $b $c", 'ba:ba ad:ae 10', "pos() works with () = m//; Bug 20010814.004 (#7526)");
}
{
- # [ID 20010407.006] matching utf8 return values from
+ # [ID 20010407.006 (#6767)] matching utf8 return values from
# functions does not work
- my $message = 'UTF-8 return values from functions; Bug 20010407.006';
+ my $message = 'UTF-8 return values from functions; Bug 20010407.006 (#6767)';
package ID_20010407_006;
sub x {"a\x{1234}"}
my $x = x;
}
{
- my $message = "s///eg [change 13f46d054db22cf4]; Bug 20020124.005";
+ my $message = "s///eg [change 13f46d054db22cf4]; Bug 20020124.005 (#8335)";
for my $char ("a", "\x{df}", "\x{100}") {
my $x = "$char b $char";
}
{
- my $message = "Correct pmop flags checked when empty pattern; Bug 20020412.005";
+ my $message = "Correct pmop flags checked when empty pattern; Bug 20020412.005 (#8935)";
# Requires reuse of last successful pattern.
my $num = 123;
}
{
- my $message = 'UTF-8 regex matches above 32k; Bug 20020630.002';
+ my $message = 'UTF-8 regex matches above 32k; Bug 20020630.002 (#10013)';
for (['byte', "\x{ff}"], ['utf8', "\x{1ff}"]) {
my ($type, $char) = @$_;
for my $len (32000, 32768, 33000) {
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
require './test.pl';
+ set_up_inc( '../lib', '.' );
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 8;
chdir 't' if -d 't';
require './test.pl';
skip_all_if_miniperl("no dynamic loading on miniperl, no Scalar::Util");
- plan(tests => 14);
}
+plan(tests => 14);
+
# [perl 72922]: A 'copy' of a Regex object which has magic should not crash
# When a Regex object was copied and the copy weaken then the original regex object
# could no longer be 'copied' with qr//
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 4;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
undef &Regexp::DESTROY;
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 1;
(abc)?(abc)+ abc y $1:$2 :abc -
'b\s^'m a\nb\n n - -
\ba a y - -
-^(a(??{"(?!)"})|(a)(?{1}))b ab y $2 a # [ID 20010811.006]
-ab(?i)cd AbCd n - - # [ID 20010809.023]
+^(a(??{"(?!)"})|(a)(?{1}))b ab y $2 a # [ID 20010811.006 (#7512)]
+ab(?i)cd AbCd n - - # [ID 20010809.023 (#7503)]
ab(?i)cd abCd y - -
(A|B)*(?(1)(CD)|(CD)) CD y $2-$3 -CD
(A|B)*(?(1)(CD)|(CD)) ABCD y $2-$3 CD-
-(A|B)*?(?(1)(CD)|(CD)) CD y $2-$3 -CD # [ID 20010803.016]
+(A|B)*?(?(1)(CD)|(CD)) CD y $2-$3 -CD # [ID 20010803.016 (#7438)]
(A|B)*?(?(1)(CD)|(CD)) ABCD y $2-$3 CD-
'^(o)(?!.*\1)'i Oo n - -
(.*)\d+\1 abc12bc y $1 bc
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
require './test.pl';
+ set_up_inc( '../lib', '.' );
skip_all_if_miniperl("no dynamic loading on miniperl, no re");
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use utf8;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_if_miniperl("no dynamic loading on miniperl, no File::Spec");
}
BEGIN {
chdir 't' if -d 't';
- @INC = qw '../lib ../ext/re';
require './test.pl';
- skip_all_without_unicode_tables();
+ set_up_inc( qw '../lib ../ext/re' );
eval 'require Config'; # assume defaults if this fails
}
+skip_all_without_unicode_tables();
+
use strict;
use open qw(:utf8 :std);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_if_miniperl("no dynamic loading on miniperl, no Tie::Hash::NamedCapture");
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.','../ext/re');
require './test.pl';
require './charset_tools.pl';
require './loc_tools.pl';
- skip_all_without_unicode_tables();
+ set_up_inc( '../lib','.','../ext/re' );
}
+skip_all_without_unicode_tables();
+
use strict;
use warnings;
fresh_perl_like('no warnings "experimental::regex_sets"; qr/(?[ ! ! (\w])/',
qr/^Unmatched \(/, {},
'qr/(?[ ! ! (\w])/ doesnt panic');
+
# The following didn't panic before, but easy to add this here with a
# paren between the !!
fresh_perl_like('no warnings "experimental::regex_sets";qr/(?[ ! ( ! (\w)])/',
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.','../ext/re');
require './test.pl';
+ set_up_inc( '../lib', '.', '../ext/re' );
+}
if (is_miniperl()) {
skip_all_if_miniperl("Unicode tables not built yet", 2)
unless eval 'require "unicore/Heavy.pl"';
}
-}
plan tests => 3;
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.','../ext/re');
require Config; import Config;
require './test.pl';
- skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
- skip_all_without_unicode_tables();
+ set_up_inc('../lib','.','../ext/re');
}
+skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
+skip_all_without_unicode_tables();
+
plan tests => 58; #** update watchdog timeouts proportionally when adding tests
use strict;
ok ($s !~ /.*?:::\s*ab/ms, 'PREGf_IMPLICIT/ms');
ok ($s !~ /.*?:::\s*ab/msi,'PREGf_IMPLICIT/msi');
+
for my $star ('*', '{0,}') {
for my $greedy ('', '?') {
for my $flags ('', 'i', 'm', 'mi') {
{
local $main::TODO = 'regdump gets mangled by the VMS pipe implementation' if $^O eq 'VMS';
fresh_perl_like(<<"PROG", qr/\b\Q$text\E\b/, {}, "/.${star}${greedy}X/${flags}${s} anchors implicitly");
-BEGIN { \@INC = ('../lib', '.', '../ext/re'); }
+BEGIN { require './test.pl'; set_up_inc('../lib', '.', '../ext/re'); }
use re 'debug';
qr/.${star}${greedy}:::\\s*ab/${flags}${s}
PROG
}
}
+
{
# [perl #127855] Slowdown in m//g on COW strings of certain lengths
# this should take milliseconds, but took 10's of seconds.
/e;
};
is $locker{key}, '3', 'locking target in $hash{key} =~ s//.../e';
- like $@, qr/^Modification of a read-only value/, 'err msg';
+ like $@, qr/^Modification of a read-only value/, 'err msg' . ($@ ? ": $@" : "");
}
delete $::{does_not_exist}; # just in case
eval { no warnings; $::{does_not_exist}=~s/(?:)/*{"does_not_exist"}; 4/e };
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
EXPECT
ok
########
-# [ID 20001202.002] and change #8066 added 'at -e line 1';
+# [ID 20001202.002 (#4821)] and change #8066 added 'at -e line 1';
# reversed again as a result of [perl #17763]
die qr(x)
EXPECT
(?^:x)
########
-# 20001210.003 mjd@plover.com
+# 20001210.003 (#4893) mjd@plover.com
format REMITOUT_TOP =
FOO
.
close STDERR; die;
EXPECT
########
-# core dump in 20000716.007
+# core dump in 20000716.007 (#3516)
-w
"x" =~ /(\G?x)?/;
########
-# Bug 20010515.004
+# Bug 20010515.004 (#6998)
my @h = 1 .. 10;
bad(@h);
sub bad {
O
Use of freed value in iteration at - line 7.
########
-# Bug 20010506.041
+# Bug 20010506.041 (#6952)
"abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
EXPECT
ok
BEGIN { print "ok\n" }
EXPECT
ok
-######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155]
+######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155 (#7947)]
# This only happens if the filename is 11 characters or less.
$foo = \-f "blah";
print "ok" if ref $foo && !$$foo;
EXPECT
ok
-######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1
+######## [ID 20011128.159 (#7951)] 'X' =~ /\X/ segfault in 5.6.1
print "ok" if 'X' =~ /\X/;
EXPECT
ok
print $x;
EXPECT
ok 1
-######## [ID 20020623.009] nested eval/sub segfaults
+######## [ID 20020623.009 (#9728)] nested eval/sub segfaults
$eval = eval 'sub { eval "sub { %S }" }';
$eval->({});
######## [perl #17951] Strange UTF error
{ stderr => 1 },
"No perlio debug file without -Di...");
ok(!-e $perlio_log, "...no perlio.txt found");
- fresh_perl_is("print qq(hello\n)", "\nEXECUTING...\n\nhello\n",
+ fresh_perl_like("print qq(hello\n)", qr/\nEXECUTING...\n{1,2}hello\n?/,
{ stderr => 1, switches => [ "-Di" ] },
"Perlio debug file with both -Di and PERLIO_DEBUG...");
ok(-e $perlio_log, "... perlio debugging file found with -Di and PERLIO_DEBUG");
is( $r, 'foo1', '-s on the shebang line' );
}
-# Bug ID 20011106.084
+# Bug ID 20011106.084 (#7876)
$filename = tempfile();
SKIP: {
open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
# returned, with $? set to the exit code. Unless overridden, stderr is
# redirected to stdout.
+ die sprintf "Third argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})"
+ unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH';
+
# Given the choice of the mis-parsable {}
# (we want an anon hash, but a borked lexer might think that it's a block)
# or relying on taking a reference to a lexical
# Same on AIX
my $curr = threads->create({
stack_size => $^O eq 'hpux' ? 524288 :
- $^O eq 'darwin' ? 1000000:
+ $^O eq 'darwin' ? 2000000:
$^O eq 'VMS' ? 150000 :
$^O eq 'aix' ? 1000000 : 0,
}, sub {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
skip_all_if_miniperl("miniperl can't load attributes");
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use utf8;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
plan( tests => 18 );
}
::is( $c[3], "ｍａｉｎ::__ANON__", "anonymous subroutine name" );
::ok( $c[4], "hasargs true with anon sub" );
-# Bug 20020517.003, used to dump core
+# Bug 20020517.003 (#9367), used to dump core
sub ｆｏｏ { @c = caller(0) }
my $fooref = delete $ｍａｉｎ::{ｆｏｏ};
$fooref -> ();
BEGIN {
- require "test.pl";
+ require "./test.pl";
set_up_inc(qw(../lib .));
skip_all_without_unicode_tables();
}
is ($state, 'ok');
}
-# [ID 20010526.001] localized glob loses value when assigned to
+# [ID 20010526.001 (#7038)] localized glob loses value when assigned to
$Ｊ=1; %Ｊ=(a=>1); @Ｊ=(1); local *Ｊ=*Ｊ; *Ｊ = sub{};
# tests that utf8_heavy.pl doesn't use anything that prevents it loading
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 1;
$| = 1;
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
require './charset_tools.pl';
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
skip_all_without_unicode_tables();
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib ../cpan/parent/lib);
require "./test.pl"; require './charset_tools.pl';
+ set_up_inc( qw(. ../lib ../cpan/parent/lib) );
}
use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = qw '../lib ../dist/base/lib';
require './test.pl';
+ set_up_inc(qw '../lib ../dist/base/lib');
}
use utf8;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require Config; import Config;
require './test.pl';
require './charset_tools.pl';
require './loc_tools.pl';
+ set_up_inc( '../lib' );
}
plan(tests => 215);
skip_all_without_unicode_tables();
}
-plan (tests => 52);
+plan (tests => 55);
use utf8;
use open qw( :utf8 :std );
{stderr => 1}, "RT# 124216");
}
+
+SKIP: { # [perl #128738]
+ use Config;
+ if ($Config{uvsize} < 8) {
+ skip("test is only valid on 64-bit ints", 2);
+ }
+ else {
+ no warnings 'deprecated';
+ my $a;
+ eval "\$a = q \x{ffffffff}Hello, \\\\whirled!\x{ffffffff}";
+ is $@, "",
+ "No errors in eval'ing a string with large code point delimiter";
+ is $a, 'Hello, \whirled!',
+ "Got expected result in eval'ing a string with a large code point"
+ . " delimiter";
+ }
+}
+
+
+# New tests go here ^^^^^
+
+# Keep this test last, as it will mess up line number reporting for any
+# subsequent tests.
+
+<<END;
+${
+#line 57
+qq ϟϟ }
+END
+is __LINE__, 59, '#line directive and qq with uni delims inside heredoc';
+
+# Put new tests above the line number tests.
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use utf8;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib .);
require "./test.pl";
+ set_up_inc(qw(../lib .));
}
plan tests => 52;
}
{
- # 20010407.008 sprintf removes utf8-ness
+ # 20010407.008 (#6769) sprintf removes utf8-ness
$a = sprintf "\x{1234}";
is((sprintf "%x %d", unpack("U*", $a), length($a)), "1234 1",
'\x{1234}');
BEGIN {
chdir 't' if -d 't';
- @INC = qw '../lib ../dist/base/lib';
$| = 1;
require "./test.pl";
+ set_up_inc(qw '../lib ../dist/base/lib');
}
use utf8;
#define PL_multi_open (PL_parser->multi_open)
#define PL_multi_close (PL_parser->multi_close)
#define PL_preambled (PL_parser->preambled)
-#define PL_sublex_info (PL_parser->sublex_info)
#define PL_linestr (PL_parser->linestr)
#define PL_expect (PL_parser->expect)
#define PL_copline (PL_parser->copline)
STATIC void
S_missingterm(pTHX_ char *s)
{
- char tmpbuf[3];
+ char tmpbuf[UTF8_MAXBYTES + 1];
char q;
+ bool uni = FALSE;
+ SV *sv;
if (s) {
char * const nl = strrchr(s,'\n');
if (nl)
*nl = '\0';
+ uni = UTF;
}
- else if ((U8) PL_multi_close < 32) {
+ else if (PL_multi_close < 32) {
*tmpbuf = '^';
tmpbuf[1] = (char)toCTRL(PL_multi_close);
tmpbuf[2] = '\0';
s = tmpbuf;
}
else {
- *tmpbuf = (char)PL_multi_close;
- tmpbuf[1] = '\0';
+ if (LIKELY(PL_multi_close < 256)) {
+ *tmpbuf = (char)PL_multi_close;
+ tmpbuf[1] = '\0';
+ }
+ else {
+ uni = TRUE;
+ *uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close) = 0;
+ }
s = tmpbuf;
}
q = strchr(s,'"') ? '\'' : '"';
- Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
+ sv = sv_2mortal(newSVpv(s,0));
+ if (uni)
+ SvUTF8_on(sv);
+ Perl_croak(aTHX_ "Can't find string terminator %c%"SVf
+ "%c anywhere before EOF",q,SVfARG(sv),q);
}
#include "feature.h"
PerlIO_close(parser->rsfp);
SvREFCNT_dec(parser->rsfp_filters);
SvREFCNT_dec(parser->lex_stuff);
- SvREFCNT_dec(parser->sublex_info.repl);
+ SvREFCNT_dec(parser->lex_sub_repl);
Safefree(parser->lex_brackstack);
Safefree(parser->lex_casestack);
CopLINE_set(PL_curcop, line_num);
}
-#define skipspace(s) skipspace_flags(s, 0)
-
-
STATIC void
S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
{
}
/*
- * S_skipspace
+ * skipspace
* Called to gobble the appropriate amount and type of whitespace.
* Skips comments as well.
+ * Returns the next character after the whitespace that is skipped.
+ *
+ * peekspace
+ * Same thing, but look ahead without incrementing line numbers or
+ * adjusting PL_linestart.
*/
+#define skipspace(s) skipspace_flags(s, 0)
+#define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
+
STATIC char *
S_skipspace_flags(pTHX_ char *s, U32 flags)
{
return THING;
}
- PL_sublex_info.super_state = PL_lex_state;
- PL_sublex_info.sub_inwhat = (U16)op_type;
- PL_sublex_info.sub_op = PL_lex_op;
+ PL_parser->lex_super_state = PL_lex_state;
+ PL_parser->lex_sub_inwhat = (U16)op_type;
+ PL_parser->lex_sub_op = PL_lex_op;
PL_lex_state = LEX_INTERPPUSH;
PL_expect = XTERM;
const bool is_heredoc = PL_multi_close == '<';
ENTER;
- PL_lex_state = PL_sublex_info.super_state;
+ PL_lex_state = PL_parser->lex_super_state;
SAVEI8(PL_lex_dojoin);
SAVEI32(PL_lex_brackets);
SAVEI32(PL_lex_allbrackets);
SAVEI32(PL_parser->herelines);
PL_parser->herelines = 0;
}
- SAVEI8(PL_multi_close);
+ SAVEIV(PL_multi_close);
SAVEPPTR(PL_bufptr);
SAVEPPTR(PL_bufend);
SAVEPPTR(PL_oldbufptr);
PL_parser->lex_shared->ls_bufptr = PL_bufptr;
PL_linestr = PL_lex_stuff;
- PL_lex_repl = PL_sublex_info.repl;
+ PL_lex_repl = PL_parser->lex_sub_repl;
PL_lex_stuff = NULL;
- PL_sublex_info.repl = NULL;
+ PL_parser->lex_sub_repl = NULL;
/* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
set for an inner quote-like operator and then an error causes scope-
popping. We must not have a PL_lex_stuff value left dangling, as
that breaks assumptions elsewhere. See bug #123617. */
SAVEGENERICSV(PL_lex_stuff);
- SAVEGENERICSV(PL_sublex_info.repl);
+ SAVEGENERICSV(PL_parser->lex_sub_repl);
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
= SvPVX(PL_linestr);
shared->ls_prev = PL_parser->lex_shared;
PL_parser->lex_shared = shared;
- PL_lex_inwhat = PL_sublex_info.sub_inwhat;
+ PL_lex_inwhat = PL_parser->lex_sub_inwhat;
if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
- PL_lex_inpat = PL_sublex_info.sub_op;
+ PL_lex_inpat = PL_parser->lex_sub_op;
else
PL_lex_inpat = NULL;
PERL_ARGS_ASSERT_SCAN_CONST;
assert(PL_lex_inwhat != OP_TRANSR);
- if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
+ if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
/* If we are doing a trans and we know we want UTF8 set expectation */
- has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
- this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
+ has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
+ this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
}
/* Protect sv from errors and fatal warnings. */
/* Subtract 3 for the bytes that were already accounted for
* (min, max, and the hyphen) */
- SvGROW(sv, SvLEN(sv) + grow - 3);
- d = SvPVX(sv) + save_offset; /* refresh d after realloc */
+ d = save_offset + SvGROW(sv, SvLEN(sv) + grow - 3);
/* Here, we expand out the range. On ASCII platforms, the
* compiler should optimize out the 'convert_unicode==TRUE'
d = (char*)uvchr_to_utf8((U8*)d, uv);
if (PL_lex_inwhat == OP_TRANS
- && PL_sublex_info.sub_op)
+ && PL_parser->lex_sub_op)
{
- PL_sublex_info.sub_op->op_private |=
+ PL_parser->lex_sub_op->op_private |=
(PL_lex_repl ? OPpTRANS_FROM_UTF
: OPpTRANS_TO_UTF);
}
}
/* Add the (Unicode) code point to the output. */
- if (OFFUNI_IS_INVARIANT(uv)) {
+ if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
*d++ = (char) LATIN1_TO_NATIVE(uv);
}
else {
}
else if (! SvUTF8(res)) {
/* Make sure \N{} return is UTF-8. This is because
- * \N{} implies Unicode semantics, and scalars have to
- * be in utf8 to guarantee those semantics; but not
- * needed in tr/// */
+ * \N{} implies Unicode semantics, and scalars have
+ * to be in utf8 to guarantee those semantics; but
+ * not needed in tr/// */
sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
str = SvPV_const(res, len);
}
SvPOK_on(sv);
if (has_utf8) {
SvUTF8_on(sv);
- if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
- PL_sublex_info.sub_op->op_private |=
+ if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
+ PL_parser->lex_sub_op->op_private |=
(PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
}
}
tmpbuf[len] = '\0';
goto bare_package;
}
- indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
- if (indirgv && GvCVu(indirgv))
+ indirgv = gv_fetchpvn_flags(tmpbuf, len,
+ GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
+ SVt_PVCV);
+ if (indirgv && SvTYPE(indirgv) != SVt_NULL
+ && (!isGV(indirgv) || GvCVu(indirgv)))
return 0;
/* filehandle or package name makes it a method */
if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
static const char* const exp_name[] =
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
"ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
- "TERMORDORDOR"
+ "SIGVAR", "TERMORDORDOR"
};
#endif
PL_lex_dojoin = FALSE;
PL_lex_state = LEX_INTERPCONCAT;
PL_lex_allbrackets--;
- return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
+ return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
}
if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
&& SvEVALED(PL_lex_repl))
PL_oldbufptr = s;
PL_parser->saw_infix_sigil = 0;
+ if (PL_in_my == KEY_sigvar) {
+ /* we expect the sigil and optional var name part of a
+ * signature element here. Since a '$' is not necessarily
+ * followed by a var name, handle it specially here; the general
+ * yylex code would otherwise try to interpret whatever follows
+ * as a var; e.g. ($, ...) would be seen as the var '$,'
+ */
+
+ char sigil;
+
+ s = skipspace(s);
+ sigil = *s++;
+ PL_bufptr = s; /* for error reporting */
+ switch (sigil) {
+ case '$':
+ case '@':
+ case '%':
+ /* spot stuff that looks like an prototype */
+ if (strchr("$:@%&*;\\[]", *s)) {
+ yyerror("Illegal character following sigil in a subroutine signature");
+ break;
+ }
+ /* '$#' is banned, while '$ # comment' isn't */
+ if (*s == '#') {
+ yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
+ break;
+ }
+ s = skipspace(s);
+ if (isIDFIRST_lazy_if(s, UTF)) {
+ char *dest = PL_tokenbuf + 1;
+ /* read var name, including sigil, into PL_tokenbuf */
+ PL_tokenbuf[0] = sigil;
+ parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
+ 0, cBOOL(UTF), FALSE);
+ *dest = '\0';
+ assert(PL_tokenbuf[1]); /* we have a variable name */
+ NEXTVAL_NEXTTOKE.ival = sigil;
+ force_next('p'); /* force a signature pending identifier */
+ }
+ else
+ PL_in_my = 0;
+ PL_expect = XOPERATOR;
+ break;
+
+ case ')':
+ PL_expect = XBLOCK;
+ break;
+ case ',': /* handle ($a,,$b) */
+ break;
+
+ default:
+ PL_in_my = 0;
+ yyerror("A signature parameter must start with '$', '@' or '%'");
+ /* very crude error recovery: skip to likely next signature
+ * element */
+ while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
+ s++;
+ break;
+ }
+ TOKEN(sigil);
+ }
+
retry:
switch (*s) {
default:
bool arrow;
STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
STRLEN soff = s - SvPVX(PL_linestr);
- s = skipspace_flags(s, LEX_NO_INCLINE);
+ s = peekspace(s);
arrow = *s == '=' && s[1] == '>';
PL_bufptr = SvPVX(PL_linestr) + bufoff;
s = SvPVX(PL_linestr) + soff;
Looks up an identifier in the pad or in a package
+ is_sig indicates that this is a subroutine signature variable
+ rather than a plain pad var.
+
Returns:
PRIVATEREF if this is a lexical name.
BAREWORD if this belongs to a package.
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
else {
+ OP *o;
if (has_colon) {
/* "my" variable %s can't be in a package */
/* PL_no_myglob is constant */
GCC_DIAG_RESTORE;
}
- pl_yylval.opval = newOP(OP_PADANY, 0);
- pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
+ if (PL_in_my == KEY_sigvar) {
+ /* A signature 'padop' needs in addition, an op_first to
+ * point to a child sigdefelem, and an extra field to hold
+ * the signature index. We can achieve both by using an
+ * UNOP_AUX and (ab)using the op_aux field to hold the
+ * index. If we ever need more fields, use a real malloced
+ * aux strut instead.
+ */
+ o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
+ INT2PTR(UNOP_AUX_item *,
+ (PL_parser->sig_elems)));
+ o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
+ : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
+ : OPpARGELEM_HV);
+ }
+ else
+ o = newOP(OP_PADANY, 0);
+ o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
UTF ? SVf_UTF8 : 0);
+ if (PL_in_my == KEY_sigvar)
+ PL_in_my = 0;
+
+ pl_yylval.opval = o;
return PRIVATEREF;
}
}
}
/*
- Whine if they've said @foo in a doublequoted string,
- and @foo isn't a variable we can find in the symbol
+ Whine if they've said @foo or @foo{key} in a doublequoted string,
+ and @foo (or %foo) isn't a variable we can find in the symbol
table.
*/
if (ckWARN(WARN_AMBIGUOUS)
&& !PL_lex_brackets)
{
GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
- ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
+ ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
+ SVt_PVAV);
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
- /* DO NOT warn for @- and @+ */
- && !( PL_tokenbuf[2] == '\0'
- && ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
)
{
/* Downgraded from fatal to warning 20000522 mjd */
else if (ck_uni && bracket == -1)
check_uni();
if (bracket != -1) {
+ bool skip;
+ char *s2;
/* If we were processing {...} notation then... */
if (isIDFIRST_lazy_if(d,is_utf8)) {
/* if it starts as a valid identifier, assume that it is one.
if ( !tmp_copline )
tmp_copline = CopLINE(PL_curcop);
- if (s < PL_bufend && isSPACE(*s)) {
- s = skipspace(s);
- }
+ if ((skip = s < PL_bufend && isSPACE(*s)))
+ /* Avoid incrementing line numbers or resetting PL_linestart,
+ in case we have to back up. */
+ s2 = peekspace(s);
+ else
+ s2 = s;
/* Expect to find a closing } after consuming any trailing whitespace.
*/
- if (*s == '}') {
+ if (*s2 == '}') {
+ /* Now increment line numbers if applicable. */
+ if (skip)
+ s = skipspace(s);
s++;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
PL_lex_state = LEX_INTERPEND;
sv_catpvs(repl, "do ");
}
sv_catpvs(repl, "{");
- sv_catsv(repl, PL_sublex_info.repl);
+ sv_catsv(repl, PL_parser->lex_sub_repl);
sv_catpvs(repl, "}");
SvEVALED_on(repl);
- SvREFCNT_dec(PL_sublex_info.repl);
- PL_sublex_info.repl = repl;
+ SvREFCNT_dec(PL_parser->lex_sub_repl);
+ PL_parser->lex_sub_repl = repl;
}
if (CopLINE(PL_curcop) != first_line) {
- sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
- ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
+ sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
+ ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xpad_cop_seq.xlow =
CopLINE(PL_curcop) - first_line;
CopLINE_set(PL_curcop, first_line);
}
o->op_private &= ~OPpTRANS_ALL;
o->op_private |= del|squash|complement|
(DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
- (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
+ (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
PL_lex_op = o;
pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
char *to; /* current position in the sv's data */
I32 brackets = 1; /* bracket nesting level */
bool has_utf8 = FALSE; /* is there any utf8 content? */
- I32 termcode; /* terminating char. code */
+ IV termcode; /* terminating char. code */
U8 termstr[UTF8_MAXBYTES]; /* terminating string */
STRLEN termlen; /* length of terminating string */
line_t herelines;
/* mark where we are */
PL_multi_start = CopLINE(PL_curcop);
- PL_multi_open = term;
+ PL_multi_open = termcode;
herelines = PL_parser->herelines;
/* find corresponding closing delimiter */
if (term && (tmps = strchr("([{< )]}> )]}>",term)))
termcode = termstr[0] = term = tmps[5];
- PL_multi_close = term;
+ PL_multi_close = termcode;
if (PL_multi_open == PL_multi_close) {
keep_bracketed_quoted = FALSE;
/* backslashes can escape the open or closing characters */
if (*s == '\\' && s+1 < PL_bufend) {
if (!keep_bracketed_quoted
- && ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
+ && ( ((UV)s[1] == PL_multi_open)
+ || ((UV)s[1] == PL_multi_close) ))
{
s++;
}
*to++ = *s++;
}
/* allow nested opens and closes */
- else if (*s == PL_multi_close && --brackets <= 0)
+ else if ((UV)*s == PL_multi_close && --brackets <= 0)
break;
- else if (*s == PL_multi_open)
+ else if ((UV)*s == PL_multi_open)
brackets++;
else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
has_utf8 = TRUE;
*/
if (PL_lex_stuff)
- PL_sublex_info.repl = sv;
+ PL_parser->lex_sub_repl = sv;
else
PL_lex_stuff = sv;
if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
#ifdef NV_MIN_EXP
if (negexp
&& -hexfp_exp < NV_MIN_EXP - 1) {
+ /* NOTE: this means that the exponent
+ * underflow warning happens for
+ * the IEEE 754 subnormals (denormals),
+ * because DBL_MIN_EXP etc are the lowest
+ * possible binary (or, rather, DBL_RADIX-base)
+ * exponent for normals, not subnormals.
+ *
+ * This may or may not be a good thing. */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"Hexadecimal float: exponent underflow");
break;
#ifdef HEXFP_UQUAD
hexfp_exp -= hexfp_frac_bits;
#endif
- hexfp_mult = pow(2.0, hexfp_exp);
+ hexfp_mult = Perl_pow(2.0, hexfp_exp);
hexfp = TRUE;
goto decimal;
}
return stmtseqop;
}
-#define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
-static OP *
-S_parse_opt_lexvar(pTHX)
-{
- I32 sigil, c;
- char *s, *d;
- OP *var;
- lex_token_boundary();
- sigil = lex_read_unichar(0);
- if (lex_peek_unichar(0) == '#') {
- qerror(Perl_mess(aTHX_ "Parse error"));
- return NULL;
- }
- lex_read_space(0);
- c = lex_peek_unichar(0);
- if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
- return NULL;
- s = PL_bufptr;
- d = PL_tokenbuf + 1;
- PL_tokenbuf[0] = (char)sigil;
- parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0,
- cBOOL(UTF), FALSE);
- PL_bufptr = s;
- if (d == PL_tokenbuf+1)
- return NULL;
- var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
- OPf_MOD | (OPpLVAL_INTRO<<8));
- var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
- return var;
-}
-
-OP *
-Perl_parse_subsignature(pTHX)
-{
- I32 c;
- int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
- OP *initops = NULL;
- lex_read_space(0);
- c = lex_peek_unichar(0);
- while (c != /*(*/')') {
- switch (c) {
- case '$': {
- OP *var, *expr;
- if (prev_type == 2)
- qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
- var = parse_opt_lexvar();
- expr = var ?
- newBINOP(OP_AELEM, 0,
- ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
- OP_RV2AV),
- newSVOP(OP_CONST, 0, newSViv(pos))) :
- NULL;
- lex_read_space(0);
- c = lex_peek_unichar(0);
- if (c == '=') {
- lex_token_boundary();
- lex_read_unichar(0);
- lex_read_space(0);
- c = lex_peek_unichar(0);
- if (c == ',' || c == /*(*/')') {
- if (var)
- qerror(Perl_mess(aTHX_ "Optional parameter "
- "lacks default expression"));
- } else {
- OP *defexpr = parse_termexpr(0);
- if (defexpr->op_type == OP_UNDEF
- && !(defexpr->op_flags & OPf_KIDS))
- {
- op_free(defexpr);
- } else {
- OP *ifop =
- newBINOP(OP_GE, 0,
- scalar(newUNOP(OP_RV2AV, 0,
- newGVOP(OP_GV, 0, PL_defgv))),
- newSVOP(OP_CONST, 0, newSViv(pos+1)));
- expr = var ?
- newCONDOP(0, ifop, expr, defexpr) :
- newLOGOP(OP_OR, 0, ifop, defexpr);
- }
- }
- prev_type = 1;
- } else {
- if (prev_type == 1)
- qerror(Perl_mess(aTHX_ "Mandatory parameter "
- "follows optional parameter"));
- prev_type = 0;
- min_arity = pos + 1;
- }
- if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
- if (expr)
- initops = op_append_list(OP_LINESEQ, initops,
- newSTATEOP(0, NULL, expr));
- max_arity = ++pos;
- } break;
- case '@':
- case '%': {
- OP *var;
- if (prev_type == 2)
- qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
- var = parse_opt_lexvar();
- if (c == '%') {
- OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
- newBINOP(OP_BIT_AND, 0,
- scalar(newUNOP(OP_RV2AV, 0,
- newGVOP(OP_GV, 0, PL_defgv))),
- newSVOP(OP_CONST, 0, newSViv(1))),
- op_convert_list(OP_DIE, 0,
- op_convert_list(OP_SPRINTF, 0,
- op_append_list(OP_LIST,
- newSVOP(OP_CONST, 0,
- newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
- newSLICEOP(0,
- op_append_list(OP_LIST,
- newSVOP(OP_CONST, 0, newSViv(1)),
- newSVOP(OP_CONST, 0, newSViv(2))),
- newOP(OP_CALLER, 0))))));
- if (pos != min_arity)
- chkop = newLOGOP(OP_AND, 0,
- newBINOP(OP_GT, 0,
- scalar(newUNOP(OP_RV2AV, 0,
- newGVOP(OP_GV, 0, PL_defgv))),
- newSVOP(OP_CONST, 0, newSViv(pos))),
- chkop);
- initops = op_append_list(OP_LINESEQ,
- newSTATEOP(0, NULL, chkop),
- initops);
- }
- if (var) {
- OP *slice = pos ?
- op_prepend_elem(OP_ASLICE,
- newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_ASLICE, 0,
- list(newRANGE(0,
- newSVOP(OP_CONST, 0, newSViv(pos)),
- newUNOP(OP_AV2ARYLEN, 0,
- ref(newUNOP(OP_RV2AV, 0,
- newGVOP(OP_GV, 0, PL_defgv)),
- OP_AV2ARYLEN)))),
- ref(newUNOP(OP_RV2AV, 0,
- newGVOP(OP_GV, 0, PL_defgv)),
- OP_ASLICE))) :
- newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
- initops = op_append_list(OP_LINESEQ, initops,
- newSTATEOP(0, NULL,
- newASSIGNOP(OPf_STACKED, var, 0, slice)));
- }
- prev_type = 2;
- max_arity = -1;
- } break;
- default:
- parse_error:
- qerror(Perl_mess(aTHX_ "Parse error"));
- return NULL;
- }
- lex_read_space(0);
- c = lex_peek_unichar(0);
- switch (c) {
- case /*(*/')': break;
- case ',':
- do {
- lex_token_boundary();
- lex_read_unichar(0);
- lex_read_space(0);
- c = lex_peek_unichar(0);
- } while (c == ',');
- break;
- default:
- goto parse_error;
- }
- }
- if (min_arity != 0) {
- initops = op_append_list(OP_LINESEQ,
- newSTATEOP(0, NULL,
- newLOGOP(OP_OR, 0,
- newBINOP(OP_GE, 0,
- scalar(newUNOP(OP_RV2AV, 0,
- newGVOP(OP_GV, 0, PL_defgv))),
- newSVOP(OP_CONST, 0, newSViv(min_arity))),
- op_convert_list(OP_DIE, 0,
- op_convert_list(OP_SPRINTF, 0,
- op_append_list(OP_LIST,
- newSVOP(OP_CONST, 0,
- newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
- newSLICEOP(0,
- op_append_list(OP_LIST,
- newSVOP(OP_CONST, 0, newSViv(1)),
- newSVOP(OP_CONST, 0, newSViv(2))),
- newOP(OP_CALLER, 0))))))),
- initops);
- }
- if (max_arity != -1) {
- initops = op_append_list(OP_LINESEQ,
- newSTATEOP(0, NULL,
- newLOGOP(OP_OR, 0,
- newBINOP(OP_LE, 0,
- scalar(newUNOP(OP_RV2AV, 0,
- newGVOP(OP_GV, 0, PL_defgv))),
- newSVOP(OP_CONST, 0, newSViv(max_arity))),
- op_convert_list(OP_DIE, 0,
- op_convert_list(OP_SPRINTF, 0,
- op_append_list(OP_LIST,
- newSVOP(OP_CONST, 0,
- newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
- newSLICEOP(0,
- op_append_list(OP_LIST,
- newSVOP(OP_CONST, 0, newSViv(1)),
- newSVOP(OP_CONST, 0, newSViv(2))),
- newOP(OP_CALLER, 0))))))),
- initops);
- }
- return initops;
-}
-
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
* LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE
* LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE
* LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE
+ * LONG_DOUBLE_IS_VAX_H_FLOAT
* LONG_DOUBLE_IS_UNKNOWN_FORMAT
* It is only defined if the system supports long doubles.
*/
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE 6
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE 7
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE 8
+#define LONG_DOUBLE_IS_VAX_H_FLOAT 9
#define LONG_DOUBLE_IS_UNKNOWN_FORMAT -1
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_LE /* back-compat */
#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE /* back-compat */
*/
/*#define HAS_FUTIMES / **/
+/* HAS_GAI_STRERROR:
+ * This symbol, if defined, indicates that the gai_strerror routine
+ * is available to translate error codes returned by getaddrinfo()
+ * into human readable strings.
+ */
+/*#define HAS_GAI_STRERROR / **/
+
/* HAS_GETADDRINFO:
* This symbol, if defined, indicates that the getaddrinfo() function
* is available for use.
* This symbol, if defined, indicates that the querylocale routine is
* available to return the name of the locale for a category mask.
*/
+/* I_XLOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <xlocale.h> to get uselocale() and its friends.
+ */
/*#define HAS_NEWLOCALE / **/
/*#define HAS_FREELOCALE / **/
/*#define HAS_USELOCALE / **/
/*#define HAS_QUERYLOCALE / **/
+/*#define I_XLOCALE / **/
/* HAS_NEXTAFTER:
* This symbol, if defined, indicates that the nextafter routine is
#endif
/* Generated from:
- * 8559c6ec4e935f6478ac3149c106aed3eacfd60544281f97fd1383110d8a5cce config_h.SH
- * 3b14c76342a834042da506e8c3b4269f7d545453079733cb740970ab9cc4294e uconfig.sh
+ * 42be1deadbcceadd92a1463d6c11c441bad7c83fe2a4cd1c2ebec7742bb5e8a3 config_h.SH
+ * 0fca2bf99ac976bba919b593a18bacd059c581dbe6c8638dc0861b1e613b8406 uconfig.sh
* ex: set ro: */
d_ftello='undef'
d_ftime='undef'
d_futimes='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='stdarg.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs='y'
inc_version_list_init='NULL'
installstyle='lib/perl5'
d_ftello='undef'
d_ftime='undef'
d_futimes='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='stdarg.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs='y'
inc_version_list_init='NULL'
installstyle='lib/perl5'
}
-XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
-XS(XS_Internals_hv_clear_placehold)
-{
- dXSARGS;
-
- if (items != 1 || !SvROK(ST(0)))
- croak_xs_usage(cv, "hv");
- else {
- HV * const hv = MUTABLE_HV(SvRV(ST(0)));
- hv_clear_placeholders(hv);
- XSRETURN(0);
- }
-}
-
XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO_get_layers)
{
XSRETURN(0);
}
-XS(XS_hash_util_bucket_ratio); /* prototype to pass -Wmissing-prototypes */
-XS(XS_hash_util_bucket_ratio)
-{
- dXSARGS;
- SV *rhv;
- PERL_UNUSED_VAR(cv);
-
- if (items != 1)
- croak_xs_usage(cv, "hv");
-
- rhv= ST(0);
- if (SvROK(rhv)) {
- rhv= SvRV(rhv);
- if ( SvTYPE(rhv)==SVt_PVHV ) {
- SV *ret= Perl_hv_bucket_ratio(aTHX_ (HV*)rhv);
- ST(0)= ret;
- XSRETURN(1);
- }
- }
- XSRETURN_UNDEF;
-}
-
-XS(XS_hash_util_num_buckets); /* prototype to pass -Wmissing-prototypes */
-XS(XS_hash_util_num_buckets)
-{
- dXSARGS;
- SV *rhv;
- PERL_UNUSED_VAR(cv);
-
- if (items != 1)
- croak_xs_usage(cv, "hv");
-
- rhv= ST(0);
- if (SvROK(rhv)) {
- rhv= SvRV(rhv);
- if ( SvTYPE(rhv)==SVt_PVHV ) {
- XSRETURN_UV(HvMAX((HV*)rhv)+1);
- }
- }
- XSRETURN_UNDEF;
-}
-
-XS(XS_hash_util_used_buckets); /* prototype to pass -Wmissing-prototypes */
-XS(XS_hash_util_used_buckets)
-{
- dXSARGS;
- SV *rhv;
- PERL_UNUSED_VAR(cv);
-
- if (items != 1)
- croak_xs_usage(cv, "hv");
-
- rhv= ST(0);
- if (SvROK(rhv)) {
- rhv= SvRV(rhv);
- if ( SvTYPE(rhv)==SVt_PVHV ) {
- XSRETURN_UV(HvFILL((HV*)rhv));
- }
- }
- XSRETURN_UNDEF;
-}
-
XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_is_regexp)
{
if (items != 0)
croak_xs_usage(cv, "");
- SP -= items;
- PUTBACK;
-
if (!rx)
XSRETURN_UNDEF;
{"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
{"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
{"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
- {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
{"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
- {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
+ {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
{"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
- {"Hash::Util::bucket_ratio", XS_hash_util_bucket_ratio, "\\%"},
- {"Hash::Util::num_buckets", XS_hash_util_num_buckets, "\\%"},
- {"Hash::Util::used_buckets", XS_hash_util_used_buckets, "\\%"},
{"re::is_regexp", XS_re_is_regexp, "$"},
{"re::regname", XS_re_regname, ";$$"},
{"re::regnames", XS_re_regnames, ";$"},
/* Here is not a continuation byte, nor an invariant. The only thing left
* is a start byte (possibly for an overlong) */
-#ifdef EBCDIC
- uv = NATIVE_UTF8_TO_I8(uv);
-#endif
-
- /* Remove the leading bits that indicate the number of bytes in the
- * character's whole UTF-8 sequence, leaving just the bits that are part of
- * the value */
- uv &= UTF_START_MASK(expectlen);
+ /* Convert to I8 on EBCDIC (no-op on ASCII), then remove the leading bits
+ * that indicate the number of bytes in the character's whole UTF-8
+ * sequence, leaving just the bits that are part of the value. */
+ uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
/* Now, loop through the remaining bytes in the character's sequence,
* accumulating each into the working value as we go. Be sure to not look
*
* Non-binary properties are stored in as many bits as necessary to represent
* their values (32 currently, though the code is more general than that), not
- * as single bits, but the principal is the same: the value for each key is a
+ * as single bits, but the principle is the same: the value for each key is a
* vector that encompasses the property values for all code points whose UTF-8
* representations are represented by the key. That is, for all code points
* whose UTF-8 representations are length N bytes, and the key is the first N-1
* rarely do we need to distinguish them. The term "NATIVE_UTF8" applies to
* whichever one is applicable on the current platform */
#ifdef PERL_SMALL_MACRO_BUFFER
-#define NATIVE_UTF8_TO_I8(ch) (ch)
-#define I8_TO_NATIVE_UTF8(ch) (ch)
+#define NATIVE_UTF8_TO_I8(ch) ((U8) (ch))
+#define I8_TO_NATIVE_UTF8(ch) ((U8) (ch))
#else
#define NATIVE_UTF8_TO_I8(ch) (__ASSERT_(FITS_IN_8_BITS(ch)) ((U8) (ch)))
#define I8_TO_NATIVE_UTF8(ch) (__ASSERT_(FITS_IN_8_BITS(ch)) ((U8) (ch)))
*/
#define UVCHR_SKIP(uv) ( UVCHR_IS_INVARIANT(uv) ? 1 : __BASE_UNI_SKIP(uv))
-/* As explained in the comments for __COMMON_UNI_SKIP, 32 start bytes with
+/* The largest code point representable by two UTF-8 bytes on this platform.
+ * As explained in the comments for __COMMON_UNI_SKIP, 32 start bytes with
* UTF_ACCUMULATION_SHIFT bits of information each */
#define MAX_UTF8_TWO_BYTE (32 * (1U << UTF_ACCUMULATION_SHIFT) - 1)
-/* constrained by EBCDIC which has 5 bits per continuation byte */
+/* The largest code point representable by two UTF-8 bytes on any platform that
+ * Perl runs on. This value is constrained by EBCDIC which has 5 bits per
+ * continuation byte */
#define MAX_PORTABLE_UTF8_TWO_BYTE (32 * (1U << 5) - 1)
/* The maximum number of UTF-8 bytes a single Unicode character can
$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
+BEGIN { pop @INC if $INC[-1] eq '.' }
use File::Temp;
######################################################################
print OUT <<'!NO!SUBS!';
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
use strict;
use Config;
print OUT <<'!NO!SUBS!';
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
use warnings;
=head1 NAME
# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
+BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use IO::File;
use Getopt::Std;
my @patches = Config::local_patches();
my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches;
+BEGIN { pop @INC if $INC[-1] eq '.' }
use warnings;
use strict;
use Config;
# This "$file" file was generated by "$0"
require 5;
-BEGIN { \$^W = 1 if \$ENV{'PERLDOCDEBUG'} }
+BEGIN {
+ \$^W = 1 if \$ENV{'PERLDOCDEBUG'};
+ pop \@INC if \$INC[-1] eq '.';
+}
use Pod::Perldoc;
exit( Pod::Perldoc->run() );
print OUT <<'!NO!SUBS!';
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
sub usage {
warn "@_\n" if @_;
print << " EOUSAGE";
if \$running_under_some_shell;
!GROK!THIS!
+print OUT <<'!NO!SUBS!';
+
+BEGIN { pop @INC if $INC[-1] eq '.' }
+
+!NO!SUBS!
+
while (<IN>) {
print OUT unless /^package diagnostics/;
}
extra.pods : miniperl
@ @extra_pods.com
-PERLDELTA_CURRENT = [.pod]perl5253delta.pod
+PERLDELTA_CURRENT = [.pod]perl5254delta.pod
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
html/
mini/
Extensions_static
+.coreheaders
dlutils.c
perllibst.h
perlmain.c
GCCCROSS := i686-w64-mingw32
endif
-GCCTARGET := $(shell $(GCCBIN) -dumpmachine)
-GCCVER1 := $(shell for /f "delims=. tokens=1,2,3" %%i in ('gcc -dumpversion') do echo %%i)
-GCCVER2 := $(shell for /f "delims=. tokens=1,2,3" %%i in ('gcc -dumpversion') do echo %%j)
-GCCVER3 := $(shell for /f "delims=. tokens=1,2,3" %%i in ('gcc -dumpversion') do echo %%k)
##
## Build configuration. Edit the values below to suit your needs.
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER := \5.25.3
+#INST_VER := \5.25.4
#
# Comment this out if you DON'T want your perl installation to have
# Visual C++ 2013 Express Edition (aka Visual C++ 12.0) (free version)
#CCTYPE := MSVC120FREE
# MinGW or mingw-w64 with gcc-3.4.5 or later
-CCTYPE := GCC
+#CCTYPE := GCC
#
# If you are using Intel C++ Compiler uncomment this
BUILDOPT += -DWIN32_NO_REGISTRY
endif
+ifeq ($(CCTYPE),GCC)
+GCCTARGET := $(shell $(GCCBIN) -dumpmachine)
+endif
+
+#no explicit CCTYPE given, do auto detection
+ifeq ($(CCTYPE),)
+GCCTARGET := $(shell $(GCCBIN) -dumpmachine 2>NUL)
+#do we have a GCC?
+ifneq ($(GCCTARGET),)
+CCTYPE := GCC
+else
+#use var to capture 1st line only, not 8th token of lines 2 & 3 in cl.exe output
+#rmving the cmd /c causes the var2b undef4echo but!4"set MSVCVER", cmd.exe bug?
+MSVCVER := $(shell (set MSVCVER=) & (for /f "tokens=8 delims=.^ " \
+ %%i in ('cl ^2^>^&1') do if not defined MSVCVER set /A "MSVCVER=%%i-6") \
+ & cmd /c echo %%MSVCVER%%)
+CCTYPE := MSVC$(MSVCVER)0
+endif
+endif
+
+
ifeq ($(CCTYPE),GCC)
ifeq ($(GCCTARGET),x86_64-w64-mingw32)
WIN64 := define
MINIBUILDOPT += -D__USE_MINGW_ANSI_STDIO
endif
+GCCVER1 := $(shell for /f "delims=. tokens=1,2,3" %%i in ('gcc -dumpversion') do echo %%i)
+GCCVER2 := $(shell for /f "delims=. tokens=1,2,3" %%i in ('gcc -dumpversion') do echo %%j)
+GCCVER3 := $(shell for /f "delims=. tokens=1,2,3" %%i in ('gcc -dumpversion') do echo %%k)
+
# If you are using GCC, 4.3 or later by default we add the -fwrapv option.
# See https://rt.perl.org/Ticket/Display.html?id=121505
#
BITCOUNT_H = ..\bitcount.h
MG_DATA_H = ..\mg_data.h
GENERATED_HEADERS = $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
-#a stub ppport.h must be generated so building XS modules, .c->.obj wise, will
-#work, so this target also represents creating the COREDIR and filling it
-HAVE_COREDIR = $(COREDIR)\ppport.h
+
+HAVE_COREDIR = .coreheaders
MICROCORE_OBJ = $(MICROCORE_SRC:.c=$(o))
CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:.c=$(o))
all : info rebasePE Extensions_nonxs $(PERLSTATIC)
info :
+ @echo # CCTYPE=$(CCTYPE)
+ifeq ($(CCTYPE),GCC)
@echo # GCCBIN=$(GCCBIN)
@echo # GCCVER=$(GCCVER1).$(GCCVER2).$(GCCVER3)
@echo # GCCTARGET=$(GCCTARGET)
@echo # GCCCROSS=$(GCCCROSS)
+endif
@echo # WIN64=$(WIN64)
@echo # ARCHITECTURE=$(ARCHITECTURE)
@echo # ARCHNAME=$(ARCHNAME)
@echo # MAKE=$(PLMAKE)
-ifeq ($(GCCTARGET),)
+ifeq ($(CCTYPE),)
@echo Unable to detect gcc and/or architecture!
@exit 1
endif
$(EMBED_EXE_MANI)
endif
-#This generates a stub ppport.h & creates & fills /lib/CORE to allow for XS
-#building .c->.obj wise (linking is a different thing). This target is AKA
-#$(HAVE_COREDIR).
-$(COREDIR)\ppport.h : $(CORE_H)
+.PHONY: MakePPPort
+
+MakePPPort : $(HAVEMINIPERL) $(CONFIGPM)
+ $(MINIPERL) -I..\lib ..\mkppport
+
+# also known as $(HAVE_COREDIR)
+.coreheaders : $(CORE_H)
$(XCOPY) *.h $(COREDIR)\\*.*
$(RCOPY) include $(COREDIR)\\*.*
$(XCOPY) ..\\*.h $(COREDIR)\\*.*
# DynaLoader.pm, so this will have to do
#most of deps of this target are in DYNALOADER and therefore omitted here
-Extensions : $(PERLDEP) $(DYNALOADER) $(GLOBEXE)
+Extensions : $(PERLDEP) $(DYNALOADER) $(GLOBEXE) MakePPPort
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(PLMAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --dynamic !Unicode/Normalize
Extensions_normalize : $(PERLDEP) $(DYNALOADER) $(GLOBEXE) $(UNIDATAFILES)
Extensions_reonly : $(PERLDEP) $(DYNALOADER)
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(PLMAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --dynamic +re
-Extensions_static : ..\make_ext.pl list_static_libs.pl $(CONFIGPM) $(GLOBEXE) $(HAVE_COREDIR)
+Extensions_static : ..\make_ext.pl list_static_libs.pl $(CONFIGPM) $(GLOBEXE) $(HAVE_COREDIR) MakePPPort
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(PLMAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --static
$(MINIPERL) -I..\lib list_static_libs.pl > Extensions_static
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5253delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5254delta.pod
$(MINIPERL) -I..\lib $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5253delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5254delta.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 \
-@erase $(PERLDLL)
-@erase $(CORE_OBJ)
-@erase $(GENUUDMAP) $(GENUUDMAP_OBJ) $(GENERATED_HEADERS)
+ -@erase .coreheaders
-if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
-if exist $(UNIDATADIR1) rmdir /s /q $(UNIDATADIR1)
-if exist $(UNIDATADIR2) rmdir /s /q $(UNIDATADIR2)
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER = \5.25.3
+#INST_VER = \5.25.4
#
# Comment this out if you DON'T want your perl installation to have
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5253delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5254delta.pod
cd ..\win32
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5253delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5254delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \
perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \
perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \
d_ftello='undef'
d_ftime='define'
d_futimes='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='varargs.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs=''
inc_version_list=''
inc_version_list_init='0'
d_ftello='undef'
d_ftime='define'
d_futimes='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='varargs.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs=''
inc_version_list=''
inc_version_list_init='0'
d_ftello='undef'
d_ftime='define'
d_futimes='undef'
+d_gai_strerror='undef'
d_gdbm_ndbm_h_uses_prototypes='undef'
d_gdbmndbm_h_uses_prototypes='undef'
d_getaddrinfo='undef'
i_varargs='undef'
i_varhdr='varargs.h'
i_vfork='undef'
+i_xlocale='undef'
ignore_versioned_solibs=''
inc_version_list=''
inc_version_list_init='0'
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER *= \5.25.3
+#INST_VER *= \5.25.4
#
# Comment this out if you DON'T want your perl installation to have
# Visual C++ 2013 Express Edition (aka Visual C++ 12.0) (free version)
#CCTYPE = MSVC120FREE
# MinGW or mingw-w64 with gcc-3.4.5 or later
-CCTYPE *= GCC
+#CCTYPE = GCC
#
# If you are using GCC, 4.3 or later by default we add the -fwrapv option.
BUILDOPT += -DWIN32_NO_REGISTRY
.ENDIF
+#no explicit CCTYPE given, do auto detection
+.IF "$(CCTYPE)" == ""
+GCCTARGET *= $(shell gcc -dumpmachine 2>NUL & exit /b 0)
+#do we have a GCC?
+.IF "$(GCCTARGET)" != ""
+CCTYPE = GCC
+else
+#use var to capture 1st line only, not 8th token of lines 2 & 3 in cl.exe output
+MSVCVER := $(shell (set MSVCVER=) & (for /f "tokens=8 delims=.^ " \
+ %i in ('cl ^2^>^&1') do @if not defined MSVCVER set /A "MSVCVER=%i-6"))
+CCTYPE := MSVC$(MSVCVER)0
+endif
+endif
+
PROCESSOR_ARCHITECTURE *= x86
.IF "$(WIN64)" == "undef"
BITCOUNT_H = ..\bitcount.h
MG_DATA_H = ..\mg_data.h
GENERATED_HEADERS = $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
-#a stub ppport.h must be generated so building XS modules, .c->.obj wise, will
-#work, so this target also represents creating the COREDIR and filling it
-HAVE_COREDIR = $(COREDIR)\ppport.h
+
+HAVE_COREDIR = .\.coreheaders
MICROCORE_OBJ = $(MICROCORE_SRC:db:+$(o))
CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:db:+$(o))
.ENDIF
$(GENUUDMAP) $(GENERATED_HEADERS)
-#This generates a stub ppport.h & creates & fills /lib/CORE to allow for XS
-#building .c->.obj wise (linking is a different thing). This target is AKA
-#$(HAVE_COREDIR).
-$(COREDIR)\ppport.h : $(CORE_H)
+MakePPPort : $(HAVEMINIPERL) $(CONFIGPM)
+ $(MINIPERL) -I..\lib ..\mkppport
+
+# also known as $(HAVE_COREDIR)
+.\.coreheaders : $(CORE_H)
$(XCOPY) *.h $(COREDIR)\*.* && $(RCOPY) include $(COREDIR)\*.* && $(XCOPY) ..\*.h $(COREDIR)\*.*
rem. > $@
# DynaLoader.pm, so this will have to do
#most of deps of this target are in DYNALOADER and therefore omitted here
-Extensions : $(PERLDEP) $(DYNALOADER) $(GLOBEXE)
+Extensions : $(PERLDEP) $(DYNALOADER) $(GLOBEXE) MakePPPort
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(PLMAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --dynamic !Unicode/Normalize
Extensions_normalize : $(PERLDEP) $(DYNALOADER) $(GLOBEXE) $(UNIDATAFILES)
Extensions_reonly : $(PERLDEP) $(DYNALOADER)
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(PLMAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --dynamic +re
-Extensions_static : ..\make_ext.pl list_static_libs.pl $(CONFIGPM) $(GLOBEXE) $(HAVE_COREDIR)
+Extensions_static : ..\make_ext.pl list_static_libs.pl $(CONFIGPM) $(GLOBEXE) $(HAVE_COREDIR) MakePPPort
$(MINIPERL) -I..\lib ..\make_ext.pl "MAKE=$(PLMAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --static
$(MINIPERL) -I..\lib list_static_libs.pl > Extensions_static
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5253delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5254delta.pod
$(MINIPERL) -I..\lib $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5253delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5254delta.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 \
installbare : utils ..\pod\perltoc.pod
$(PERLEXE) ..\installperl
- attrib -r $(INST_COREDIR)\ppport.h && del $(INST_COREDIR)\ppport.h
if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.*
if exist $(PERLEXESTATIC) $(XCOPY) $(PERLEXESTATIC) $(INST_BIN)\*.*
$(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
-@erase $(PERLDLL)
-@erase $(CORE_OBJ)
-@erase $(GENUUDMAP) $(GENUUDMAP_OBJ) $(GENERATED_HEADERS)
+ -@erase .coreheaders
-if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
-if exist $(UNIDATADIR1) rmdir /s /q $(UNIDATADIR1)
-if exist $(UNIDATADIR2) rmdir /s /q $(UNIDATADIR2)
perl5251delta.pod \
perl5252delta.pod \
perl5253delta.pod \
+ perl5254delta.pod \
perl561delta.pod \
perl56delta.pod \
perl581delta.pod \
perl5251delta.man \
perl5252delta.man \
perl5253delta.man \
+ perl5254delta.man \
perl561delta.man \
perl56delta.man \
perl581delta.man \
perl5251delta.html \
perl5252delta.html \
perl5253delta.html \
+ perl5254delta.html \
perl561delta.html \
perl56delta.html \
perl581delta.html \
perl5251delta.tex \
perl5252delta.tex \
perl5253delta.tex \
+ perl5254delta.tex \
perl561delta.tex \
perl56delta.tex \
perl581delta.tex \
projects / platform / upstream / perl.git / commitdiff