diff options
383 files changed, 34751 insertions, 8462 deletions
diff --git a/.gitignore b/.gitignore index 74b65eba75..a20fbf93e2 100644 --- a/.gitignore +++ b/.gitignore @@ -76,6 +76,7 @@ ext.libs /uudmap.h /bitcount.h +lib/inc/ lib/Win32.pm lib/Win32API/ lib/Win32CORE.pm @@ -12,7 +12,7 @@ # code kit is, of course, allowed.) -- A. C. Yardley <yardley@tanet.net> -Aaron Crane <perl@aaroncrane.co.uk> +Aaron Crane <perl@aaroncrane.co.uk> Aaron B. Dossett <aaron@iglou.com> Aaron J. Mackey <ajm6q@virginia.edu> Abe Timmerman <abe@ztreet.demon.nl> @@ -40,7 +40,7 @@ Albert Dvornik <bert@alum.mit.edu> Alessandro Forghieri <alf@orion.it> Alexei Alexandrov <alexei.alexandrov@gmail.com> Alex Davies <adavies@ptc.com> -Alex Gough <alex@rcon.org> +Alex Gough <alex@rcon.org> Alex Vandiver <alexmv@mit.edu> Alex Waugh <alex@alexwaugh.com> Alexander Bluhm <alexander_bluhm@genua.de> @@ -159,7 +159,7 @@ Carl Eklof <CEklof@endeca.com> Carl M. Fongheiser <cmf@ins.infonet.net> Carl Witty <cwitty@newtonlabs.com> Cary D. Renzema <caryr@mxim.com> -Casey R. Tweten <crt@kiski.net> +Casey R. Tweten <crt@kiski.net> Casey West <casey@geeknest.com> Castor Fu Chaim Frenkel <chaimf@pobox.com> @@ -265,7 +265,7 @@ David J. Fiander <davidf@mks.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 McLean <davem@icc.gsfc.nasa.gov> David Manura <dm.list@math2.org> David Mitchell <davem@iabyn.nospamdeletethisbit.com> David Muir Sharnoff <muir@idiom.com> @@ -335,7 +335,7 @@ Frank Wiegand <frank.wiegand@gmail.com> Franklin Chen <chen@adi.com> François Désarménien <desar@club-internet.fr> Fréderic Chauveau <fmc@pasteur.fr> -Fyodor Krasnov <fyodor@aha.ru> +Fyodor Krasnov <fyodor@aha.ru> G. Del Merritt <del@intranetics.com> Gabe Schaffer Gabor Szabo <szabgab@gmail.com> @@ -343,13 +343,13 @@ Garry T. Williams <garry@zvolve.com> Gary Clark <GaryC@mail.jeld-wen.com> Gary L. Armstrong Gary Ng <71564.1743@compuserve.com> -Geoffrey T. Dairiki <dairiki@dairiki.org> +Geoffrey T. Dairiki <dairiki@dairiki.org> Geoffrey F. Green <geoff-public@stuebegreen.com> Georg Schwarz <geos@epost.de> George Greer <perl@greerga.m-l.org> George Necula <necula@eecs.berkeley.edu> Geraint A Edwards <gedge@serf.org> -Gerard Goossen <gerard@tty.nl> +Gerard Goossen <gerard@ggoossen.net> Gerben Wierda <G.C.Th.Wierda@AWT.nl> Gerd Knops <gerti@BITart.com> Gerrit P. Haase <gp@familiehaase.de> @@ -389,6 +389,7 @@ Hans Dieter Pearcey <hdp@pobox.com> Hans Ginzel <hans@kolej.mff.cuni.cz> Hans Mulder <hansmu@xs4all.nl> Hans Ranke <Hans.Ranke@ei.tum.de> +Harmen <harm@dds.nl> Harmon S. Nine <hnine@netarx.com> Harri Pasanen <harri.pasanen@trema.com> Harry Edmon <harry@atmos.washington.edu> @@ -437,7 +438,7 @@ Jamshid Afshar Jan D. <jan.djarv@mbox200.swipnet.se> Jan Dubois <jand@activestate.com> Jan Pazdziora <adelton@fi.muni.cz> -Jan Starzynski <jan@planet.de> +Jan Starzynski <jan@planet.de> Jan-Erik Karlsson <trg@privat.utfors.se> Jan-Pieter Cornet <johnpc@xs4all.nl> Jared Rhine <jared@organic.com> @@ -456,7 +457,7 @@ Jeff Bouis Jeff McDougal <jmcdo@cris.com> Jeff Okamoto <okamoto@corp.hp.com> Jeff Pinyan <japhy@pobox.com> -Jeff Siegal <jbs@eddie.mit.edu> +Jeff Siegal <jbs@eddie.mit.edu> Jeff Urlwin <jurlwin@access.digex.net> Jeffrey Friedl <jfriedl@regex.info> Jeffrey S. Haemer <jsh@woodcock.boulder.qms.com> @@ -573,7 +574,7 @@ Ken MacLeod <ken@bitsko.slc.ut.us> Ken Neighbors Ken Shan <ken@digitas.harvard.edu> Ken Williams <ken@mathforum.org> -Kenichi Ishigaki <ishigaki@cpan.org> +Kenichi Ishigaki <ishigaki@cpan.org> Kenneth Albanowski <kjahds@kjahds.com> Kenneth Duda <kjd@cisco.com> Keong Lim <Keong.Lim@sr.com.au> @@ -588,7 +589,7 @@ Kirrily Robert <skud@infotrope.net> Kiyotaka Sakai <ksakai@netwk.ntt-at.co.jp> Kragen Sitaker <kragen@pobox.com> Krishna Sethuraman <krishna@sgi.com> -Kriton Kyrimis <kyrimis@princeton.edu> +Kriton Kyrimis <kyrimis@princeton.edu> Kurt D. Starsinic <kstar@wolfetech.com> Kyriakos Georgiou Larry Parmelee <parmelee@CS.Cornell.EDU> @@ -750,7 +751,7 @@ Olivier Blin <blino@mandriva.com> Olli Savia Ollivier Robert <roberto@keltia.freenix.fr> Olivier Thauvin <olivier.thauvin@aerov.jussieu.fr> -Osvaldo Villalon <ovillalon@dextratech.com> +Osvaldo Villalon <ovillalon@dextratech.com> Owen Taylor <owt1@cornell.edu> parv <parv@pair.com> Papp Zoltan <padre@elte.hu> @@ -760,7 +761,7 @@ Patrick Dugnolle <patrick.dugnolle@bnpparibas.com> Patrick Hayes <Patrick.Hayes.CAP_SESA@renault.fr> Patrick O'Brien <pdo@cs.umd.edu> Paul A Sand <pas@unh.edu> -Paul Boven <p.boven@sara.nl> +Paul Boven <p.boven@sara.nl> Paul David Fardy <pdf@morgan.ucs.mun.ca> Paul Eggert <eggert@twinsun.com> Paul Fenwick <pjf@perltraining.com.au> @@ -803,6 +804,7 @@ Philip Hazel <ph10@cus.cam.ac.uk> Philip M. Gollucci <pgollucci@p6m7g8.com> Philip Newton <pne@cpan.org> Philippe M. Chiasson <gozer@ActiveState.com> +Philippe Bruhat (BooK) <book@cpan.org> Piers Cawley <pdcawley@bofh.org.uk> Piotr Fusik <pfusik@op.pl> Piotr Klaban <makler@oryl.man.torun.pl> @@ -857,7 +859,7 @@ Robert Partington <rjp@riffraff.plig.net> Robert Sanders <Robert.Sanders@linux.org> Robert Sebastian Gerus <arachnist@gmail.com> Robert Spier <rspier@pobox.com> -Roberto C. Sanchez <roberto@connexer.com> +Roberto C. Sanchez <roberto@connexer.com> Robin Barker <RMBarker@cpan.org> Robin Houston <robin@cpan.org> Rocco Caputo <troc@netrus.net> @@ -867,14 +869,14 @@ Ronald F. Guilmette <rfg@monkeys.com> Ronald J. Kimball <rjk@linguist.dartmouth.edu> Ronald Schmidt <RonaldWS@aol.com> Ruben Schattevoy <schattev@imb-jena.de> -Rudolph Todd Maceyko <rm55+@pitt.edu> +Rudolph Todd Maceyko <rm55+@pitt.edu> Rujith S. de Silva <desilva@netbox.com> Russ Allbery <rra@stanford.edu> Russell Fulton <russell@ccu1.auckland.ac.nz> Russell Mosemann <mose@ccsn.edu> Ryan Herbert <rherbert@sycamorehq.com> Salvador Fandiño <sfandino@yahoo.com> -Salvador Ortiz Garcia <sog@msg.com.mx> +Salvador Ortiz Garcia <sog@msg.com.mx> Sam Tregar <sam@tregar.com> Sam Vilain <sam@vilain.net> Samuli Kärkkäinen <skarkkai@woods.iki.fi> @@ -1024,7 +1026,7 @@ Wayne Thompson <Wayne.Thompson@Ebay.sun.com> Wilfredo Sánchez <wsanchez@mit.edu> William J. Middleton <William.Middleton@oslo.mobil.telenor.no> William Mann <wmann@avici.com> -William Middleton <wmiddlet@adobe.com> +William Middleton <wmiddlet@adobe.com> William R Ward <hermit@BayView.COM> William Setzer <William_Setzer@ncsu.edu> William Williams <biwillia@cisco.com> @@ -16,16 +16,21 @@ # The dist package (which contains metaconfig) is available via SVN: # svn co https://svn.sourceforge.net/svnroot/dist/trunk/dist # +# Though this script was generated by metaconfig from metaunits, it is +# OK to send patches against Configure itself. It's up to the Configure +# pumpkin to backport the patch to the metaunits if it is accepted. +# For more information on patching Configure, see pod/perlhack.pod +# +# The metaunits are also available from the public git repository: +# http://perl5.git.perl.org/metaconfig.git/ or +# $ git clone git://perl5.git.perl.org/metaconfig.git metaconfig # -# Though this script was generated by metaconfig, it is OK to send -# patches against it. It's up to the Configure pumpkin to backport -# the patch to the metaunits if it is accepted. # See Porting/pumpkin.pod for more information on metaconfig. # # $Id: Head.U 6 2006-08-25 22:21:46Z rmanfredi $ # -# Generated on Mon Oct 19 16:23:09 CEST 2009 [metaconfig 3.5 PL0] +# Generated on Fri Nov 6 07:43:05 CET 2009 [metaconfig 3.5 PL0] # (with additional metaconfig patches by perlbug@perl.org) cat >c1$$ <<EOF @@ -348,6 +353,8 @@ optimize='' cf_email='' cf_by='' cf_time='' +charbits='' +charsize='' contains='' cpp_stuff='' cpplast='' @@ -18816,6 +18823,86 @@ esac : set the base revision baserev=5.0 +: check for length of character +echo " " +case "$charsize" in +'') + echo "Checking to see how big your characters are (hey, you never know)..." >&4 + $cat >try.c <<EOCP +#include <stdio.h> +#$i_stdlib I_STDLIB +#ifdef I_STDLIB +#include <stdlib.h> +#endif +int main() +{ + printf("%d\n", (int)sizeof(char)); + exit(0); +} +EOCP + set try + if eval $compile_ok; then + dflt=`$run ./try` + else + dflt='1' + echo "(I can't seem to compile the test program. Guessing...)" + fi + ;; +*) + dflt="$charsize" + ;; +esac +rp="What is the size of a character (in bytes)?" +. ./myread +charsize="$ans" +$rm_try + +: Check for the number of bits in a character +case "$charbits" in +'') echo "Checking how long a character is (in bits)..." >&4 + $cat >try.c <<EOCP +#include <stdio.h> +int main () +{ + int n; + unsigned char c; + for (c = 1, n = 0; c; c <<= 1, n++) ; + printf ("%d\n", n); + return (0); + } +EOCP + set try + if eval $compile_ok; then + dflt=`$run ./try` + else + dflt='8' + echo "(I can't seem to compile the test program. Guessing...)" + fi + ;; +*) + dflt="$charbits" + ;; +esac +rp="What is the length of a character (in bits)?" +. ./myread +charbits="$ans" +$rm_try +case "$charbits" in +8) ;; +*) cat >&4 << EOM +Your system has an unsigned character size of $charbits bits, which +is rather unusual (normally it is 8 bits). Perl likely will not work +correctly on your system, with subtle bugs in various places. +EOM + rp='Do you really want to continue?' + dflt='n' + . ./myread + case "$ans" in + [yY]) echo >&4 "Okay, continuing." ;; + *) exit 1 ;; + esac +esac + : how do we concatenate cpp tokens here? echo " " echo "Checking to see how your cpp does stuff like concatenate tokens..." >&4 @@ -21389,7 +21476,7 @@ case "$osname::$gccversion" in tHdrH=_tmpHdr rm -f $tHdrH'.h' $tHdrH touch $tHdrH'.h' - if cpp -dM $tHdrH'.h' > $tHdrH'_cppsym.h' && [ -s $tHdrH'_cppsym.h' ]; then + if $cpp -dM $tHdrH'.h' > $tHdrH'_cppsym.h' && [ -s $tHdrH'_cppsym.h' ]; then sed 's/#define[\ \ ]*//;s/[\ \ ].*$//' <$tHdrH'_cppsym.h' >$tHdrH'_cppsym.real' if [ -s $tHdrH'_cppsym.real' ]; then cat $tHdrH'_cppsym.real' Cppsym.know | sort | uniq | ./Cppsym | sort | uniq > Cppsym.true @@ -21646,9 +21733,7 @@ nonxs_extensions='' : Function to recursively find available extensions, ignoring DynaLoader : NOTE: recursion limit of 10 to prevent runaway in case of symlink madness : In 5.10.1 and later, extensions are stored in directories -: like File-Glob instead of the older File/Glob/. In this scheme, -: IO-Compress does not appear to be an XS extension, but we want -: to install it as one. A.D. 8/2009. +: like File-Glob instead of the older File/Glob/. find_extensions=' for xxx in *; do case "$xxx" in @@ -21676,8 +21761,6 @@ find_extensions=' known_extensions="$known_extensions $this_ext"; elif $contains "\.c$" $$.tmp > /dev/null 2>&1; then known_extensions="$known_extensions $this_ext"; - elif $test "$this_ext" = "IO/Compress"; then - known_extensions="$known_extensions $this_ext"; elif $test -d $xxx; then nonxs_extensions="$nonxs_extensions $this_ext"; fi; @@ -21836,6 +21919,13 @@ for xxx in $known_extensions ; do $define) avail_ext="$avail_ext $xxx" ;; esac ;; + XS/APItest/KeywordRPN|xs/apitest/keywordrpn) + # This is just for testing. Skip it unless we have dynamic loading. + + case "$usedl" in + $define) avail_ext="$avail_ext $xxx" ;; + esac + ;; XS/Typemap|xs/typemap) # This is just for testing. Skip it unless we have dynamic loading. case "$usedl" in @@ -22203,6 +22293,8 @@ ccversion='$ccversion' cf_by='$cf_by' cf_email='$cf_email' cf_time='$cf_time' +charbits='$charbits' +charsize='$charsize' chgrp='$chgrp' chmod='$chmod' chown='$chown' diff --git a/Cross/Makefile-cross-SH b/Cross/Makefile-cross-SH index 73d4454e4f..79bd165924 100755 --- a/Cross/Makefile-cross-SH +++ b/Cross/Makefile-cross-SH @@ -342,9 +342,9 @@ plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text \ addedbyconf = UU $(shextract) $(plextract) lib/lib.pm pstruct # Unicode data files generated by mktables -unidatafiles = lib/unicore/Canonical.pl lib/unicore/Exact.pl \ - lib/unicore/Properties lib/unicore/Decomposition.pl \ - lib/unicore/CombiningClass.pl lib/unicore/Name.pl lib/unicore/PVA.pl +unidatafiles = lib/unicore/Decomposition.pl lib/unicore/TestProp.pl \ + lib/unicore/CombiningClass.pl lib/unicore/Name.pl \ + lib/unicore/Heavy.pl lib/unicore/mktables.lst # Directories of Unicode data files generated by mktables unidatadirs = lib/unicore/To lib/unicore/lib @@ -755,8 +755,10 @@ lib/lib.pm: miniperl $(CONFIGPM) unidatafiles $(unidatafiles): uni.data uni.data: miniperl$(EXE_EXT) $(CONFIGPM) lib/unicore/mktables - cd lib/unicore && $(LDLIBPTH) ../../miniperl -I../../lib mktables -w - touch uni.data + cd lib/unicore && $(LDLIBPTH) ../../miniperl -I../../lib mktables -P ../../pod -maketest -makelist -p +# Commented out so always runs, mktables looks at far more files than we +# can in this makefile to decide if needs to run or not +# touch uni.data extra.pods: miniperl -@test ! -f extra.pods || rm -f `cat extra.pods` diff --git a/Cross/config.sh-arm-linux b/Cross/config.sh-arm-linux index 4a903a2510..39a570b852 100644 --- a/Cross/config.sh-arm-linux +++ b/Cross/config.sh-arm-linux @@ -36,8 +36,8 @@ api_subversion='0' api_version='11' api_versionstring='5.11.0' ar='ar' -archlib='/usr/lib/perl5/5.11.1/armv4l-linux' -archlibexp='/usr/lib/perl5/5.11.1/armv4l-linux' +archlib='/usr/lib/perl5/5.11.2/armv4l-linux' +archlibexp='/usr/lib/perl5/5.11.2/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -55,7 +55,7 @@ castflags='0' cat='cat' cc='cc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.11.1/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.11.2/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='arm-linux-gcc' @@ -64,6 +64,7 @@ ccversion='' cf_by='red' cf_email='red@criticalintegration.com' cf_time='Wed Sep 3 22:24:58 EDT 2003' +charbits='8' chgrp='' chmod='chmod' chown='' @@ -546,7 +547,7 @@ doublesize='8' drand01='drand48()' drand48_r_proto='0' dtrace='' -dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared' +dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared' eagain='EAGAIN' ebcdic='undef' echo='echo' @@ -561,7 +562,7 @@ endservent_r_proto='0' eunicefix=':' exe_ext='' expr='expr' -extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared Errno' +extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared Errno' extras='' fflushNULL='define' fflushall='undef' @@ -718,7 +719,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.11.1/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.11.2/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -726,13 +727,13 @@ installman1dir='./install_me_here/usr/share/man/man1' 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.11.1' +installprivlib='./install_me_here/usr/lib/perl5/5.11.2' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.11.1/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.11.2/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.11.1' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.11.2' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -751,7 +752,7 @@ issymlink='/usr/bin/test -h' ivdformat='"ld"' ivsize='4' ivtype='long' -known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared' +known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared' ksh='' ld='cc' lddlflags='-shared -L/usr/local/lib' @@ -860,8 +861,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.11.1' -privlibexp='/usr/lib/perl5/5.11.1' +privlib='/usr/lib/perl5/5.11.2' +privlibexp='/usr/lib/perl5/5.11.2' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -926,17 +927,17 @@ sig_num='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 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.11.1/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.11.1/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.11.2/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.11.2/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.11.1' +sitelib='/usr/lib/perl5/site_perl/5.11.2' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.11.1' +sitelibexp='/usr/lib/perl5/site_perl/5.11.2' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -973,7 +974,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='1' +subversion='2' sysman='/usr/share/man/man1' tail='' tar='' @@ -1060,8 +1061,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.11.1' -version_patchlevel_string='version 11 subversion 1' +version='5.11.2' +version_patchlevel_string='version 11 subversion 2' versiononly='undef' vi='' voidflags='15' @@ -1076,7 +1077,7 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=11 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=11 PERL_API_SUBVERSION=0 diff --git a/Cross/config.sh-arm-linux-n770 b/Cross/config.sh-arm-linux-n770 index 3e5ebdd1fe..79614c818c 100644 --- a/Cross/config.sh-arm-linux-n770 +++ b/Cross/config.sh-arm-linux-n770 @@ -36,8 +36,8 @@ api_subversion='0' api_version='11' api_versionstring='5.11.0' ar='ar' -archlib='/usr/lib/perl5/5.11.1/armv4l-linux' -archlibexp='/usr/lib/perl5/5.11.1/armv4l-linux' +archlib='/usr/lib/perl5/5.11.2/armv4l-linux' +archlibexp='/usr/lib/perl5/5.11.2/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -55,7 +55,7 @@ castflags='0' cat='cat' cc='arm-none-linux-gnueabi-gcc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.11.1/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.11.2/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='arm-linux-gcc' @@ -531,7 +531,7 @@ dlsrc='dl_dlopen.xs' doublesize='8' drand01='drand48()' drand48_r_proto='0' -dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared' +dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared' eagain='EAGAIN' ebcdic='undef' echo='echo' @@ -546,7 +546,7 @@ endservent_r_proto='0' eunicefix=':' exe_ext='' expr='expr' -extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared Errno' +extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared Errno' extras='' fflushNULL='define' fflushall='undef' @@ -703,7 +703,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.11.1/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.11.2/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -711,13 +711,13 @@ installman1dir='./install_me_here/usr/share/man/man1' 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.11.1' +installprivlib='./install_me_here/usr/lib/perl5/5.11.2' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.11.1/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.11.2/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.11.1' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.11.2' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -736,7 +736,7 @@ issymlink='/usr/bin/test -h' ivdformat='"ld"' ivsize='4' ivtype='long' -known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared' +known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared' ksh='' ld='arm-none-linux-gnueabi-gcc' lddlflags='-shared -L/usr/local/lib' @@ -845,8 +845,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.11.1' -privlibexp='/usr/lib/perl5/5.11.1' +privlib='/usr/lib/perl5/5.11.2' +privlibexp='/usr/lib/perl5/5.11.2' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -907,17 +907,17 @@ sig_num='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 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.11.1/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.11.1/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.11.2/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.11.2/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.11.1' +sitelib='/usr/lib/perl5/site_perl/5.11.2' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.11.1' +sitelibexp='/usr/lib/perl5/site_perl/5.11.2' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -954,7 +954,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='1' +subversion='2' sysman='/usr/share/man/man1' tail='' tar='' @@ -1040,8 +1040,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.11.1' -version_patchlevel_string='version 11 subversion 1' +version='5.11.2' +version_patchlevel_string='version 11 subversion 2' versiononly='undef' vi='' voidflags='15' @@ -1056,7 +1056,7 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=11 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=11 PERL_API_SUBVERSION=0 @@ -42,7 +42,7 @@ If you have problems, corrections, or questions, please see L<"Reporting Problems"> below. For information on what's new in this release, see the -pod/perl5110delta.pod file. For more information about how to find more +pod/perl5113delta.pod file. For more information about how to find more specific detail about changes, see the Changes file. =head1 DESCRIPTION @@ -75,10 +75,10 @@ directory. =head2 Changes and Incompatibilities -Please see pod/perl5110delta.pod for a description of the changes and +Please see pod/perl5113delta.pod for a description of the changes and potential incompatibilities introduced with this release. A few of the most important issues are listed below, but you should refer -to pod/perl5110delta.pod for more detailed information. +to pod/perl5113delta.pod for more detailed information. B<WARNING:> This version is not binary compatible with prior releases of Perl. If you have built extensions (i.e. modules that include C code) @@ -93,7 +93,7 @@ The standard extensions supplied with Perl will be handled automatically. On a related issue, old modules may possibly be affected by the changes in the Perl language in the current release. Please see -pod/perl5110delta.pod for a description of what's changed. See your +pod/perl5113delta.pod for a description of what's changed. See your installed copy of the perllocal.pod file for a (possibly incomplete) list of locally installed modules. Also see CPAN::autobundle for one way to make a "bundle" of your currently installed modules. @@ -524,9 +524,9 @@ The directories set up by Configure fall into three broad categories. =item Directories for the perl distribution -By default, Configure will use the following directories for 5.11.1. +By default, Configure will use the following directories for 5.11.2. $version is the full perl version number, including subversion, e.g. -5.11.1 or 5.9.5, and $archname is a string like sun4-sunos, +5.11.2 or 5.9.5, and $archname is a string like sun4-sunos, determined by Configure. The full definitions of all Configure variables are in the file Porting/Glossary. @@ -2335,9 +2335,9 @@ won't interfere with another version. (The defaults guarantee this for 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.11.1 + sh Configure -Dprefix=/opt/perl5.11.2 -and adding /opt/perl5.11.1/bin to the shell PATH variable. Such users +and adding /opt/perl5.11.2/bin to the shell PATH variable. Such users may also wish to add a symbolic link /usr/local/bin/perl so that scripts can still start with #!/usr/local/bin/perl. @@ -2352,11 +2352,11 @@ yet. =head2 Upgrading from 5.11.0 or earlier -B<Perl 5.11.1 is binary incompatible with Perl 5.11.0 and any earlier +B<Perl 5.11.2 is binary incompatible with Perl 5.11.1 and any earlier Perl release.> Perl modules having binary parts (meaning that a C compiler is used) will have to be recompiled to be -used with 5.11.1. If you find you do need to rebuild an extension with -5.11.1, you may safely do so without disturbing the older +used with 5.11.2. If you find you do need to rebuild an extension with +5.11.2, you may safely do so without disturbing the older installations. (See L<"Coexistence with earlier versions of perl 5"> above.) @@ -1519,10 +1519,14 @@ cpan/MIME-Base64/t/quoted-print.t See whether MIME::QuotedPrint works cpan/MIME-Base64/t/unicode.t See whether MIME::Base64 works cpan/MIME-Base64/t/warn.t See whether MIME::Base64 works cpan/Module-Build/Changes Module::Build +cpan/Module-Build/lib/inc/latest.pm Module::Build +cpan/Module-Build/lib/inc/latest/private.pm Module::Build cpan/Module-Build/lib/Module/Build/API.pod Module::Build cpan/Module-Build/lib/Module/Build/Authoring.pod Module::Build cpan/Module-Build/lib/Module/Build/Base.pm Module::Build +cpan/Module-Build/lib/Module/Build/Bundling.pod Module::Build cpan/Module-Build/lib/Module/Build/Compat.pm Module::Build +cpan/Module-Build/lib/Module/Build/ConfigData.pm Configuration for Module::Build cpan/Module-Build/lib/Module/Build/Config.pm Module::Build cpan/Module-Build/lib/Module/Build/Cookbook.pm Module::Build cpan/Module-Build/lib/Module/Build/Dumper.pm Module::Build @@ -1548,33 +1552,42 @@ cpan/Module-Build/lib/Module/Build/PPMMaker.pm Module::Build cpan/Module-Build/lib/Module/Build/Version.pm Module::Build cpan/Module-Build/lib/Module/Build/YAML.pm Module::Build cpan/Module-Build/scripts/config_data Module::Build +cpan/Module-Build/t/actions/installdeps.t Module::Build cpan/Module-Build/t/add_property.t Module::Build cpan/Module-Build/t/basic.t Module::Build -cpan/Module-Build/t/bundled/Tie/CPHash.pm Module::Build.pm +cpan/Module-Build/t/bundled/Tie/CPHash.pm Module::Build +cpan/Module-Build/t/bundle_inc.t Module::Build cpan/Module-Build/t/compat/exit.t Module::Build cpan/Module-Build/t/compat.t Module::Build -cpan/Module-Build/t/debug.t Module::Build tests +cpan/Module-Build/t/debug.t Module::Build cpan/Module-Build/t/destinations.t Module::Build cpan/Module-Build/t/extend.t Module::Build cpan/Module-Build/t/ext.t Module::Build cpan/Module-Build/t/files.t Module::Build cpan/Module-Build/t/help.t Module::Build -cpan/Module-Build/t/install_extra_target.t Module::Build tests +cpan/Module-Build/t/install_extra_target.t Module::Build cpan/Module-Build/t/install.t Module::Build cpan/Module-Build/t/lib/DistGen.pm Module::Build cpan/Module-Build/t/lib/MBTest.pm Module::Build cpan/Module-Build/t/manifypods.t Module::Build -cpan/Module-Build/t/mbyaml.t Module::Build cpan/Module-Build/t/metadata2.t Module::Build cpan/Module-Build/t/metadata.t Module::Build cpan/Module-Build/t/moduleinfo.t Module::Build +cpan/Module-Build/t/mymeta.t Module::Build cpan/Module-Build/t/new_from_context.t Module::Build cpan/Module-Build/t/notes.t Module::Build cpan/Module-Build/t/parents.t Module::Build -cpan/Module-Build/t/PL_files.t Module::Build tests +cpan/Module-Build/t/perl_mb_opt.t Module::Build +cpan/Module-Build/t/PL_files.t Module::Build cpan/Module-Build/t/pod_parser.t Module::Build cpan/Module-Build/t/ppm.t Module::Build +cpan/Module-Build/t/properties/module_name.t Module::Build +cpan/Module-Build/t/properties/needs_compiler.t Module::Build +cpan/Module-Build/t/properties/share_dir.t Module::Build +cpan/Module-Build/t/README.pod Module::Build +cpan/Module-Build/t/resume.t Module::Build cpan/Module-Build/t/runthrough.t Module::Build +cpan/Module-Build/t/sample.t Module::Build cpan/Module-Build/t/script_dist.t Module::Build cpan/Module-Build/t/test_file_exts.t Module::Build cpan/Module-Build/t/test_types.t Module::Build @@ -1582,7 +1595,7 @@ cpan/Module-Build/t/test_type.t Module::Build cpan/Module-Build/t/tilde.t Module::Build cpan/Module-Build/t/use_tap_harness.t Module::Build cpan/Module-Build/t/versions.t Module::Build -cpan/Module-Build/t/write_default_maniskip.t Module::Build tests +cpan/Module-Build/t/write_default_maniskip.t Module::Build cpan/Module-Build/t/xs.t Module::Build cpan/Module-Load-Conditional/lib/Module/Load/Conditional.pm Module::Conditional cpan/Module-Load-Conditional/t/01_Module_Load_Conditional.t Module::Conditional tests @@ -2228,7 +2241,7 @@ cpan/Test-Simple/t/BEGIN_use_ok.t Test::More use_ok() testing cpan/Test-Simple/t/buffer.t Test::Builder buffering test cpan/Test-Simple/t/Builder/Builder.t Test::Builder tests cpan/Test-Simple/t/Builder/carp.t Test::Builder test -cpan/Test-Simple/t/Builder/create.t Test::Builder test +cpan/Test-Simple/t/Builder/create.t Test::Builder test cpan/Test-Simple/t/Builder/current_test.t Test::Builder tests cpan/Test-Simple/t/Builder/current_test_without_plan.t Test::Builder tests cpan/Test-Simple/t/Builder/details.t Test::Builder tests @@ -3198,6 +3211,12 @@ ext/XS-APItest/APItest.xs XS::APItest extension ext/XS-APItest/core.c Test API functions when PERL_CORE is defined ext/XS-APItest/core_or_not.inc Code common to core.c and notcore.c ext/XS-APItest/exception.c XS::APItest extension +ext/XS-APItest-KeywordRPN/KeywordRPN.pm XS::APItest::KeywordRPN extension +ext/XS-APItest-KeywordRPN/KeywordRPN.xs XS::APItest::KeywordRPN extension +ext/XS-APItest-KeywordRPN/Makefile.PL XS::APItest::KeywordRPN extension +ext/XS-APItest-KeywordRPN/README XS::APItest::KeywordRPN extension +ext/XS-APItest-KeywordRPN/t/keyword_plugin.t test keyword plugin mechanism +ext/XS-APItest-KeywordRPN/t/multiline.t test plugin parsing across lines ext/XS-APItest/Makefile.PL XS::APItest extension ext/XS-APItest/MANIFEST XS::APItest extension ext/XS-APItest/notcore.c Test API functions when PERL_CORE is not defined @@ -3206,6 +3225,7 @@ ext/XS-APItest/t/call.t XS::APItest extension ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs ext/XS-APItest/t/my_cxt.t XS::APItest: test MY_CXT interface +ext/XS-APItest/t/my_exit.t XS::APItest: test my_exit ext/XS-APItest/t/op.t XS::APItest: tests for OP related APIs ext/XS-APItest/t/pmflag.t Test deprecation warning for Perl_pmflag() ext/XS-APItest/t/printf.t XS::APItest extension @@ -3469,12 +3489,13 @@ lib/importenv.pl Perl routine to get environment into variables lib/integer.pm For "use integer" lib/integer.t For "use integer" testing lib/Internals.t For Internals::* testing +lib/legacy.pm Pragma to preserve legacy behavior +lib/legacy.t For "use legacy" 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/look.pl A "look" equivalent -lib/Module/Build/ConfigData.pm Configuration for Module::Build lib/Net/hostent.pm By-name interface to Perl's builtin gethost* lib/Net/hostent.t See if Net::hostent works lib/Net/netent.pm By-name interface to Perl's builtin getnet* @@ -3599,7 +3620,6 @@ lib/unicore/Jamo.txt Unicode character database lib/unicore/LineBreak.txt Unicode character database lib/unicore/Makefile Unicode character database lib/unicore/mktables Unicode character database generator -lib/unicore/mktables.lst File list for mktables lib/unicore/NameAliases.txt Unicode character database lib/unicore/NamedSequences.txt Unicode character database lib/unicore/NamedSqProv.txt Unicode character database @@ -3843,6 +3863,7 @@ pod/perl5101delta.pod Perl changes in version 5.10.1 pod/perl5110delta.pod Perl changes in version 5.11.0 pod/perl5111delta.pod Perl changes in version 5.11.1 pod/perl5112delta.pod Perl changes in version 5.11.2 +pod/perl5113delta.pod Perl changes in version 5.11.3 pod/perl561delta.pod Perl changes in version 5.6.1 pod/perl56delta.pod Perl changes in version 5.6 pod/perl570delta.pod Perl changes in version 5.7.0 @@ -4136,7 +4157,7 @@ symbian/sanity.pl Helper code for config.pl symbian/sdk.pl Helper code for config.pl symbian/sisify.pl Packaging utility symbian/symbian_dll.cpp The DLL stub for Symbian -symbian/symbianish.h Header for Symbian +symbian/symbianish.h Header for Symbian symbian/symbian_proto.h Prototypes for Symbian symbian/symbian_stubs.c Stub routines for Symbian symbian/symbian_stubs.h Stub headers for Symbian @@ -4167,6 +4188,8 @@ t/comp/decl.t See if declarations work t/comp/fold.t See if constant folding works t/comp/hints.aux Auxillary file for %^H test t/comp/hints.t See if %^H works +t/comp/line_debug_0.aux Auxiliary file for @{"_<$file"} test +t/comp/line_debug.t See if @{"_<$file"} works t/comp/multiline.t See if multiline strings work t/comp/opsubs.t See if q() etc. are not parsed as functions t/comp/our.t Tests for our declaration @@ -4408,7 +4431,7 @@ t/op/numconvert.t See if accessing fields does not change numeric values t/op/oct.t See if oct and hex work t/op/ord.t See if ord works t/op/or.t See if || works in weird situations -t/op/overload_integer.t See if overload::constant for integer works after "use". +t/op/overload_integer.t See if overload::constant for integer works after "use". t/op/override.t See if operator overriding works t/op/pack.t See if pack and unpack work t/op/pos.t See if pos works @@ -4480,7 +4503,7 @@ t/porting/test_bootstrap.t Test that the instructions for test bootstrapping are t/README Instructions for regression tests t/re/pat_advanced.t See if advanced esoteric patterns work t/re/pat_advanced_thr.t See if advanced esoteric patterns work in another thread -t/re/pat_psycho.t See if insane esoteric and slow patterns work +t/re/pat_psycho.t See if insane esoteric and slow patterns work t/re/pat_psycho_thr.t See if insane esoteric and slow patterns work in another thread t/re/pat_re_eval.t See if esoteric patterns using re 'eval' work t/re/pat_re_eval_thr.t See if esoteric patterns using re 'eval' work in another thread @@ -4522,6 +4545,7 @@ t/re/substr_thr.t See if substr works in another thread t/re/subst.t See if substitution works t/re/substT.t See if substitution works with -T t/re/subst_wamp.t See if substitution works with $& present +t/re/uniprops.t Test unicode \p{} regex constructs t/run/cloexec.t Test close-on-exec. t/run/exit.t Test perl's exit status. t/run/fresh_perl.t Tests that require a fresh perl. @@ -4649,10 +4673,12 @@ win32/config.bc Win32 base line config.sh (Borland C++ build) win32/config.ce WinCE port win32/config.gc Win32 base line config.sh (MinGW build) win32/config.gc64 Win64 base line config.sh (MinGW build) +win32/config.gc64nox Win64 base line config.sh (MinGW build) win32/config_H.bc Win32 config header (Borland C++ build) win32/config_H.ce WinCE port win32/config_H.gc Win32 config header (MinGW build) win32/config_H.gc64 Win64 config header (MinGW build) +win32/config_H.gc64nox Win64 config header (MinGW build) win32/config_h.PL Perl code to convert Win32 config.sh to config.h win32/config_H.vc Win32 config header (Visual C++ build) win32/config_H.vc64 Win64 config header (Visual C++ build) @@ -4675,6 +4701,7 @@ win32/Makefile.ce WinCE port win32/makefile.mk Win32 makefile for DMAKE (BC++, VC++ builds) win32/mdelete.bat multifile delete win32/perlexe.ico perlexe.ico image file +win32/perlexe.manifest Assembly manifest file win32/perlexe.rc associated perl binary with icon win32/perlglob.c Win32 port win32/perlhost.h Perl "host" implementation @@ -1,5 +1,5 @@ name: perl -version: 5.011001 +version: 5.011002 abstract: Practical Extraction and Report Language author: perl5-porters@perl.org license: perl diff --git a/Makefile.SH b/Makefile.SH index 9589ada368..6af17bc77d 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -450,9 +450,9 @@ plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text \ addedbyconf = UU $(shextract) $(plextract) pstruct # Unicode data files generated by mktables -unidatafiles = lib/unicore/Canonical.pl lib/unicore/Exact.pl \ - lib/unicore/Properties lib/unicore/Decomposition.pl \ - lib/unicore/CombiningClass.pl lib/unicore/Name.pl lib/unicore/PVA.pl +unidatafiles = lib/unicore/Decomposition.pl lib/unicore/TestProp.pl \ + lib/unicore/CombiningClass.pl lib/unicore/Name.pl \ + lib/unicore/Heavy.pl lib/unicore/mktables.lst # Directories of Unicode data files generated by mktables unidatadirs = lib/unicore/To lib/unicore/lib @@ -481,7 +481,7 @@ mini_obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) ndt_obj = $(obj0) $(obj1) $(obj2) $(obj3) $(ARCHOBJS) obj = $(ndt_obj) $(DTRACE_O) -perltoc_pod_prereqs = extra.pods pod/perlapi.pod pod/perldelta.pod pod/perlintern.pod pod/perlmodlib.pod +perltoc_pod_prereqs = extra.pods pod/perlapi.pod pod/perldelta.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod generated_pods = pod/perltoc.pod $(perltoc_pod_prereqs) Icwd = -Icpan/Cwd -Icpan/Cwd/lib @@ -983,11 +983,13 @@ $(plextract): $(MINIPERL_EXE) $(CONFIGPM) x2p/s2p $(dynamic_ext) x2p/s2p: $(MINIPERL_EXE) $(CONFIGPM) $(dynamic_ext) x2p/s2p.PL cd x2p; $(LDLIBPTH) $(MAKE) s2p -unidatafiles $(unidatafiles): uni.data +unidatafiles $(unidatafiles) pod/perluniprops.pod: uni.data uni.data: $(MINIPERL_EXE) $(CONFIGPM) lib/unicore/mktables $(nonxs_ext) - $(MINIPERL) $(Icwd) lib/unicore/mktables -C lib/unicore -w - touch uni.data + $(MINIPERL) $(Icwd) lib/unicore/mktables -C lib/unicore -P pod -maketest -makelist -p +# Commented out so always runs, mktables looks at far more files than we +# can in this makefile to decide if needs to run or not +# touch uni.data # $(PERL_EXE) and ext because buildtoc uses Text::Wrap uses re # But also this ensures that all extensions are built before we try to scan @@ -1001,8 +1003,8 @@ pod/perlapi.pod pod/perlintern.pod: $(MINIPERL_EXE) autodoc.pl embed.fnc pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST $(MINIPERL) $(Icwd) pod/perlmodlib.PL -q -pod/perldelta.pod: pod/perl5112delta.pod - $(LNS) perl5112delta.pod pod/perldelta.pod +pod/perldelta.pod: pod/perl5113delta.pod + $(LNS) perl5113delta.pod pod/perldelta.pod extra.pods: $(MINIPERL_EXE) -@test ! -f extra.pods || rm -f `cat extra.pods` @@ -1151,7 +1153,7 @@ manicheck: FORCE $(DYNALOADER): $(MINIPERL_EXE) preplibrary FORCE $(nonxs_ext) $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS) -d_dummy $(dynamic_ext): $(MINIPERL_EXE) preplibrary makeppport $(DYNALOADER) FORCE +d_dummy $(dynamic_ext): $(MINIPERL_EXE) preplibrary makeppport $(DYNALOADER) FORCE $(PERLEXPORT) $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic s_dummy $(static_ext): $(MINIPERL_EXE) preplibrary makeppport $(DYNALOADER) FORCE @@ -1416,7 +1418,7 @@ test.taintwarn: test_prep TEST_ARGS=-taintwarn $(RUN_TESTS) choose minitest.prep: - -@test test -f lib/Config.pm || $(MAKE) lib/Config.pm $(unidatafiles) + -@test -f lib/Config.pm || $(MAKE) lib/Config.pm $(unidatafiles) @echo " " @echo "You may see some irrelevant test failures if you have been unable" @echo "to build lib/Config.pm, or the Unicode data files." diff --git a/NetWare/Makefile b/NetWare/Makefile index 20e99ff800..1923eadf82 100644 --- a/NetWare/Makefile +++ b/NetWare/Makefile @@ -86,7 +86,7 @@ NLM_VERSION = 3,20,0 # Here comes the CW tools - TO BE FILLED TO BUILD WITH CW - -MODULE_DESC = "Perl 5.11.1 for NetWare" +MODULE_DESC = "Perl 5.11.2 for NetWare" CCTYPE = CodeWarrior C_COMPILER = mwccnlm -c CPP_COMPILER = mwccnlm @@ -326,6 +326,7 @@ STORABLE_NLM = $(EXTDIR)\Storable\Storable.NLM LISTUTIL_NLM = $(EXTDIR)\List\Util.NLM MIMEBASE64_NLM = $(EXTDIR)\MIME\Base64\Base64.NLM XSAPITEST_NLM = $(EXTDIR)\XS\APItest\APItest.NLM +XSAPITESTKEYWORDRPN_NLM = $(EXTDIR)\XS\APItest\KeywordRPN\KeywordRPN.NLM XSTYPEMAP_NLM = $(EXTDIR)\XS\Typemap\Typemap.NLM UNICODENORMALIZE_NLM = $(EXTDIR)\Unicode\Normalize\Normalize.NLM @@ -350,6 +351,7 @@ EXTENSION_NLM = \ $(LISTUTIL_NLM) \ $(MIMEBASE64_NLM) \ $(XSAPITEST_NLM) \ + $(XSAPITESTKEYWORDRPN_NLM) \ $(XSTYPEMAP_NLM) \ $(UNICODENORMALIZE_NLM) \ $(FILTER_NLM) @@ -463,7 +465,7 @@ INST_NW_TOP2 = $(INST_NW_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER = \5.11.1 +INST_VER = \5.11.2 # # Comment this out if you DON'T want your perl installation to have @@ -789,7 +791,7 @@ X2P_OBJ = $(X2P_SRC:.c=.obj) DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attributes B re \ Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \ - Storable/Storable List/Util MIME/Base64/Base64 XS/APItest/APItest \ + Storable/Storable List/Util MIME/Base64/Base64 XS/APItest/APItest XS/APItest/KeywordRPN \ XS/Typemap/Typemap Unicode/Normalize/Normalize Sys/Hostname STATIC_EXT = DynaLoader @@ -817,6 +819,7 @@ STORABLE = $(EXTDIR)\Storable\Storable LISTUTIL = $(EXTDIR)\List\Util MIMEBASE64 = $(EXTDIR)\MIME\Base64\Base64 XSAPITEST = $(EXTDIR)\XS\APItest\APItest +XSAPITESTKEYWORDRPN = $(EXTDIR)\XS\APItest\KeywordRPN\KeywordRPN XSTYPEMAP = $(EXTDIR)\XS\Typemap\Typemap UNICODENORMALIZE = $(EXTDIR)\Unicode\Normalize\Normalize @@ -843,6 +846,7 @@ EXTENSION_C = \ $(LISTUTIL).c \ $(MIMEBASE64).c \ $(XSAPITEST).c \ + $(XSAPITESTKEYWORDRPN).c \ $(XSTYPEMAP).c \ $(UNICODENORMALIZE).c \ @@ -1267,6 +1271,12 @@ $(XSAPITEST_NLM): $(MAKE) cd ..\..\..\netware +$(XSAPITESTKEYWORDRPN_NLM): + cd $(EXTDIR)\XS\$(*B) + ..\..\..\miniperl -I..\..\lib Makefile.PL PERL_CORE=1 INSTALLDIRS=perl + $(MAKE) + cd ..\..\..\netware + $(XSTYPEMAP_NLM): cd $(EXTDIR)\XS\$(*B) ..\..\..\miniperl -I..\..\lib Makefile.PL PERL_CORE=1 INSTALLDIRS=perl diff --git a/NetWare/config.wc b/NetWare/config.wc index 533a59fcd9..e63d41c828 100644 --- a/NetWare/config.wc +++ b/NetWare/config.wc @@ -51,6 +51,7 @@ ccsymbols='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' +charbits='8' chgrp='' chmod='' chown='' diff --git a/NetWare/config_H.wc b/NetWare/config_H.wc index 653a139fb4..9afbad74af 100644 --- a/NetWare/config_H.wc +++ b/NetWare/config_H.wc @@ -1048,7 +1048,7 @@ * 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.11.1\\lib\\NetWare-x86-multi-thread" /**/ +#define ARCHLIB "c:\\perl\\5.11.2\\lib\\NetWare-x86-multi-thread" /**/ /*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: @@ -1079,8 +1079,8 @@ * 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.11.1\\bin\\NetWare-x86-multi-thread" /**/ -#define BIN_EXP "c:\\perl\\5.11.1\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN "c:\\perl\\5.11.2\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.11.2\\bin\\NetWare-x86-multi-thread" /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, @@ -3042,7 +3042,7 @@ * 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.11.1\\lib\\NetWare-x86-multi-thread" /**/ +#define SITEARCH "c:\\perl\\site\\5.11.2\\lib\\NetWare-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -3065,7 +3065,7 @@ * 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.11.1\\lib" /**/ +#define SITELIB "c:\\perl\\site\\5.11.2\\lib" /**/ /*#define SITELIB_EXP "" /**/ #define SITELIB_STEM "" /**/ diff --git a/Porting/Glossary b/Porting/Glossary index 167d4d3e5a..b810a7f9f3 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -249,6 +249,14 @@ cf_time (cf_who.U): Holds the output of the "date" command when the configuration file was produced. This is used to tag both config.sh and config_h.SH. +charbits (charsize.U): + This variable contains the value of the CHARBITS symbol, which + indicates to the C program how many bits there are in a character. + +charsize (charsize.U): + This variable contains the value of the CHARSIZE symbol, which + indicates to the C program how many bytes there are in a character. + chgrp (Loc.U): This variable is defined but not used by Configure. The value is the empty string and is not useful. diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index e4794c3d9d..0942b9007f 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -104,7 +104,7 @@ use File::Glob qw(:case); SIGNATURE THANKS TODO Todo VERSION WHATSNEW ); - + # Each entry in the %Modules hash roughly represents a distribution, # except in the case of CPAN=1, where it *exactly* represents a single # CPAN distribution. @@ -159,7 +159,7 @@ use File::Glob qw(:case); # Each key reprepresents a string prefix, with longest prefixes checked # first. The first match causes that prefix to be replaced with the # corresponding key. For example, with the following MAP: -# { +# { # 'lib/' => 'lib/', # '' => 'lib/Foo/', # }, @@ -167,7 +167,7 @@ use File::Glob qw(:case); # these files are mapped as shown: # # README becomes lib/Foo/README -# lib/Foo.pm becomes lib/Foo.pm +# lib/Foo.pm becomes lib/Foo.pm # # The default is dependent on the type of module. # For distributions which appear to be stored under ext/, it defaults to: @@ -176,7 +176,7 @@ use File::Glob qw(:case); # # otherwise, it's # -# { +# { # 'lib/' => 'lib/', # '' => 'lib/Foo/Bar/', # } @@ -423,7 +423,7 @@ use File::Glob qw(:case); 'CPANPLUS' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/CPANPLUS-0.89_06.tar.gz', + 'DISTRIBUTION' => 'BINGOS/CPANPLUS-0.89_09.tar.gz', 'FILES' => q[cpan/CPANPLUS], 'EXCLUDED' => [ qr{^inc/}, qr{^t/dummy-.*\.hidden$}, @@ -443,7 +443,7 @@ use File::Glob qw(:case); 'CPANPLUS::Dist::Build' => { 'MAINTAINER' => 'bingos', - 'DISTRIBUTION' => 'BINGOS/CPANPLUS-Dist-Build-0.40.tar.gz', + 'DISTRIBUTION' => 'BINGOS/CPANPLUS-Dist-Build-0.44.tar.gz', 'FILES' => q[cpan/CPANPLUS-Dist-Build], 'EXCLUDED' => [ qr{^inc/}, qw{ t/99_pod.t @@ -521,7 +521,7 @@ use File::Glob qw(:case); 'Encode' => { 'MAINTAINER' => 'dankogai', - 'DISTRIBUTION' => 'DANKOGAI/Encode-2.37.tar.gz', + 'DISTRIBUTION' => 'DANKOGAI/Encode-2.38.tar.gz', 'FILES' => q[cpan/Encode], 'CPAN' => 1, 'UPSTREAM' => undef, @@ -660,7 +660,7 @@ use File::Glob qw(:case); 'File::Fetch' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'KANE/File-Fetch-0.20.tar.gz', + 'DISTRIBUTION' => 'BINGOS/File-Fetch-0.22.tar.gz', 'FILES' => q[cpan/File-Fetch], 'CPAN' => 1, 'UPSTREAM' => 'cpan', @@ -812,7 +812,7 @@ use File::Glob qw(:case); 'IPC::Cmd' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.50.tar.gz', + 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.54.tar.gz', 'FILES' => q[cpan/IPC-Cmd], 'CPAN' => 1, 'UPSTREAM' => 'cpan', @@ -1004,10 +1004,10 @@ use File::Glob qw(:case); 'Module::Build' => { 'MAINTAINER' => 'kwilliams', - 'DISTRIBUTION' => 'DAGOLDEN/Module-Build-0.35.tar.gz', + 'DISTRIBUTION' => 'DAGOLDEN/Module-Build-0.35_09.tar.gz', 'FILES' => q[cpan/Module-Build], - 'EXCLUDED' => [ qw{ t/par.t t/signature.t scripts/bundle.pl}, - qr!^contrib/! ], + 'EXCLUDED' => [ qw{ t/par.t t/signature.t }, + qr!^contrib/!, qr!^devtools! ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', }, @@ -1015,7 +1015,7 @@ use File::Glob qw(:case); 'Module::CoreList' => { 'MAINTAINER' => 'rgarcia', - 'DISTRIBUTION' => 'RGARCIA/Module-CoreList-2.20.tar.gz', + 'DISTRIBUTION' => 'BINGOS/Module-CoreList-2.23.tar.gz', 'FILES' => q[dist/Module-CoreList], 'CPAN' => 1, 'UPSTREAM' => 'blead', @@ -1555,7 +1555,7 @@ use File::Glob qw(:case); 'threads' => { 'MAINTAINER' => 'jdhedden', - 'DISTRIBUTION' => 'JDHEDDEN/threads-1.74.tar.gz', + 'DISTRIBUTION' => 'JDHEDDEN/threads-1.75.tar.gz', 'FILES' => q[dist/threads], 'EXCLUDED' => [ qw(examples/pool.pl t/pod.t @@ -1734,6 +1734,14 @@ use File::Glob qw(:case); 'UPSTREAM' => 'cpan', }, + 'XS::APItest::KeywordRPN' => + { + 'MAINTAINER' => 'zefram', + 'FILES' => q[ext/XS-APItest-KeywordRPN], + 'CPAN' => 0, + 'UPSTREAM' => 'blead', + }, + 'XSLoader' => { 'MAINTAINER' => 'saper', @@ -1942,6 +1950,7 @@ use File::Glob qw(:case); lib/hostname.pl lib/importenv.pl lib/integer.{pm,t} + lib/legacy.{pm,t} lib/less.{pm,t} lib/locale.{pm,t} lib/look.pl diff --git a/Porting/checkAUTHORS.pl b/Porting/checkAUTHORS.pl index c2b5e4e495..cc1b6721a7 100644 --- a/Porting/checkAUTHORS.pl +++ b/Porting/checkAUTHORS.pl @@ -59,12 +59,12 @@ $map {$_} = "?" for "pxm\100nubz.org", "raf\100tradingpost.com.au", "smoketst\100hp46t243.cup.hp.com", - "root\100chronos.fi.muni.cz", # no clue - jrv 20090803 - "gomar\100md.media-web.de", # no clue - jrv 20090803 - "data-drift\100so.uio.no", # no data. originally private message from 199701282014.VAA12645@selters.uio.no - "arbor\100al37al08.telecel.pt", # reported perlbug ticket 5196 - no actual code contribution. no real name - jrv 20091006 - "oracle\100pcr8.pcr.com", # Reported perlbug ticket 1015 - no patch - Probably Ed Eddington ed@pcr.com -; + "root\100chronos.fi.muni.cz", # no clue - jrv 20090803 + "gomar\100md.media-web.de", # no clue - jrv 20090803 + "data-drift\100so.uio.no", # no data. originally private message from 199701282014.VAA12645@selters.uio.no + "arbor\100al37al08.telecel.pt", # reported perlbug ticket 5196 - no actual code contribution. no real name - jrv 20091006 + "oracle\100pcr8.pcr.com", # Reported perlbug ticket 1015 - no patch - Probably Ed Eddington ed@pcr.com + ; # # Email addresses for people that don't have an email address in AUTHORS @@ -72,45 +72,45 @@ $map {$_} = "?" for # $map {$_} = '!' for - # Nick Ing-Simmons has passed away (2006-09-25). - "nick\100ing-simmons.net", - "nik\100tiuk.ti.com", - "nick.ing-simmons\100elixent.com", - "nick\100ni-s.u-net.com", - "nick.ing-simmons\100tiuk.ti.com", - - # Iain Truskett has passed away (2003-12-29). - "perl\100dellah.anu.edu.au", - "spoon\100dellah.org", - "spoon\100cpan.org", - - # Ton Hospel - "me-02\100ton.iguana.be", - "perl-5.8.0\100ton.iguana.be", - "perl5-porters\100ton.iguana.be", - - # Beau Cox - "beau\100beaucox.com", - - # Randy W. Sims - "ml-perl\100thepierianspring.org", - - # perl internal addresses - "perl5-porters\100africa.nicoh.com", - "perlbug\100perl.org",, - "perl5-porters.nicoh.com", - "perlbug-followup\100perl.org", - "perlbug-comment\100perl.org", - "bug-module-corelist\100rt.cpan.org", - "bug-storable\100rt.cpan.org", - "bugs-perl5\100bugs6.perl.org", - "unknown", - "unknown\100unknown", - "unknown\100longtimeago", - "unknown\100perl.org", + # Nick Ing-Simmons has passed away (2006-09-25). + "nick\100ing-simmons.net", + "nik\100tiuk.ti.com", + "nick.ing-simmons\100elixent.com", + "nick\100ni-s.u-net.com", + "nick.ing-simmons\100tiuk.ti.com", + + # Iain Truskett has passed away (2003-12-29). + "perl\100dellah.anu.edu.au", + "spoon\100dellah.org", + "spoon\100cpan.org", + + # Ton Hospel + "me-02\100ton.iguana.be", + "perl-5.8.0\100ton.iguana.be", + "perl5-porters\100ton.iguana.be", + + # Beau Cox + "beau\100beaucox.com", + + # Randy W. Sims + "ml-perl\100thepierianspring.org", + + # perl internal addresses + "perl5-porters\100africa.nicoh.com", + "perlbug\100perl.org",, + "perl5-porters.nicoh.com", + "perlbug-followup\100perl.org", + "perlbug-comment\100perl.org", + "bug-module-corelist\100rt.cpan.org", + "bug-storable\100rt.cpan.org", + "bugs-perl5\100bugs6.perl.org", + "unknown", + "unknown\100unknown", + "unknown\100longtimeago", + "unknown\100perl.org", "", "(none)", -; + ; if (@authors) { @@ -273,7 +273,7 @@ craigb craig.berry\100psinetcs.com + craig.berry\100signaltreesolutions.com + craigberry\100mac.com + craig.a.berry\100gmail.com -+ craig a. berry) ++ craig a. berry) davem davem\100fdgroup.com + davem\100iabyn.nospamdeletethisbit.com + davem\100iabyn.com @@ -297,7 +297,7 @@ gbarr gbarr\100pobox.com + bodg\100tiuk.ti.com + gbarr\100ti.com + graham.barr\100tiuk.ti.com -+ gbarr\100monty.mutatus.co.uk ++ gbarr\100monty.mutatus.co.uk gisle gisle\100activestate.com + gisle\100aas.no + aas\100aas.no @@ -322,17 +322,17 @@ jesse jesse\100bestpractical.com merijn h.m.brand\100xs4all.nl + h.m.brand\100hccnet.nl + merijn\100l1.procura.nl -+ merijn\100a5.(none) ++ merijn\100a5.(none) mhx mhx-perl\100gmx.net -+ mhx\100r2d2.(none) ++ mhx\100r2d2.(none) nicholas nick\100unfortu.net + nick\100ccl4.org + nick\100talking.bollo.cx + nick\100plum.flirble.org + nick\100babyhippo.co.uk + nick\100bagpuss.unfortu.net -+ nick\100babyhippo.com -+ Nicholas Clark (sans From field in mail header) ++ nick\100babyhippo.com ++ Nicholas Clark (sans From field in mail header) pudge pudge\100pobox.com rgs rgarciasuarez\100free.fr + rgarciasuarez\100mandrakesoft.com @@ -347,7 +347,7 @@ steveh stevehay\100planit.com + steve.hay\100uk.radan.com stevep steve\100fisharerojo.org + steve.peters\100gmail.com -+ root\100dixie.cscaper.com ++ root\100dixie.cscaper.com timb Tim.Bunce\100pobox.com + tim.bunce\100ig.co.uk @@ -365,27 +365,27 @@ timb Tim.Bunce\100pobox.com + l2ot9pa02\100sneakemail.com + wyp3rlx02\100sneakemail.com + 0mgwtfbbq\100sneakemail.com -+ xyey9001\100sneakemail.com ++ xyey9001\100sneakemail.com a.r.ferreira\100gmail.com aferreira\100shopzilla.com abe\100ztreet.demon.nl abeltje\100cpan.org abela\100hsc.fr abela\100geneanet.org abigail\100abigail.be abigail\100foad.org + abigail\100abigail.nl + abigail\100fnx.com -aburt\100isis.cs.du.edu isis!aburt +aburt\100isis.cs.du.edu isis!aburt ach\100mpe.mpg.de ach\100rosat.mpe-garching.mpg.de -adavies\100ptc.com alex.davies\100talktalk.net +adavies\100ptc.com alex.davies\100talktalk.net ajohnson\100nvidia.com ajohnson\100wischip.com -+ anders\100broadcom.com ++ anders\100broadcom.com alexm\100netli.com alexm\100w-m.ru alex-p5p\100earth.li alex\100rcon.rog alexmv\100mit.edu alex\100chmrr.net alian\100cpan.org alian\100alianwebserver.com allen\100grumman.com allen\100gateway.grumman.com allen\100huarp.harvard.edu nort\100bottesini.harvard.edu -+ nort\100qnx.com ++ nort\100qnx.com allens\100cpan.org easmith\100beatrice.rutgers.edu -+ root\100dogberry.rutgers.edu ++ root\100dogberry.rutgers.edu andreas.koenig\100anima.de andreas.koenig.gmwojprw\100franz.ak.mind.de + andreas.koenig.7os6vvqr\100franz.ak.mind.de + a.koenig\100mind.de @@ -393,38 +393,38 @@ andreas.koenig\100anima.de andreas.koenig.gmwojprw\100franz.ak.mind + andk\100cpan.org + koenig\100anna.mind.de + k\100anna.mind.de -+ root\100ak-71.mind.de -+ root\100ak-75.mind.de -+ k\100sissy.in-berlin.de -+ a.koenig\100kulturbox.de -+ k\100sissy.in-berlin.de -+ root\100dubravka.in-berlin.de ++ root\100ak-71.mind.de ++ root\100ak-75.mind.de ++ k\100sissy.in-berlin.de ++ a.koenig\100kulturbox.de ++ k\100sissy.in-berlin.de ++ root\100dubravka.in-berlin.de anno4000\100lublin.zrz.tu-berlin.de anno4000\100mailbox.tu-berlin.de + siegel\100zrz.tu-berlin.de -arnold\100gnu.ai.mit.edu arnold\100emoryu2.arpa -+ gatech!skeeve!arnold -arussell\100cs.uml.edu adam\100adam-pc.(none) +arnold\100gnu.ai.mit.edu arnold\100emoryu2.arpa ++ gatech!skeeve!arnold +arussell\100cs.uml.edu adam\100adam-pc.(none) ash\100cpan.org ash_cpan\100firemirror.com avarab\100gmail.com avar\100cpan.org bailey\100newman.upenn.edu bailey\100hmivax.humgen.upenn.edu + bailey\100genetics.upenn.edu -+ bailey.charles\100gmail.com ++ bailey.charles\100gmail.com bah\100ecnvantage.com bholzman\100longitude.com -barries\100slaysys.com root\100jester.slaysys.com -bkedryna\100home.com bart\100cg681574-a.adubn1.nj.home.com +barries\100slaysys.com root\100jester.slaysys.com +bkedryna\100home.com bart\100cg681574-a.adubn1.nj.home.com bcarter\100gumdrop.flyinganvil.org q.eibcartereio.=~m-b.{6}-cgimosx\100gumdrop.flyinganvil.org ben_tilly\100operamail.com btilly\100gmail.com -+ ben_tilly\100hotmail.com -ben\100morrow.me.uk mauzo\100csv.warwick.ac.uk -+ mauzo\100.(none) -bepi\100perl.it enrico.sorcinelli\100gmail.com -bert\100alum.mit.edu bert\100genscan.com ++ ben_tilly\100hotmail.com +ben\100morrow.me.uk mauzo\100csv.warwick.ac.uk ++ mauzo\100.(none) +bepi\100perl.it enrico.sorcinelli\100gmail.com +bert\100alum.mit.edu bert\100genscan.com brian.d.foy\100gmail.com bdfoy\100cpan.org -BQW10602\100nifty.com sadahiro\100cpan.org +BQW10602\100nifty.com sadahiro\100cpan.org chromatic\100wgz.org chromatic\100rmci.net -clintp\100geeksalad.org cpierce1\100ford.com +clintp\100geeksalad.org cpierce1\100ford.com clkao\100clkao.org clkao\100bestpractical.com corion\100corion.net corion\100cpan.org cp\100onsitetech.com publiustemp-p5p\100yahoo.com @@ -435,39 +435,40 @@ cpan\100audreyt.org autrijus\100egb.elixus.org + autrijus\100ossf.iis.sinica.edu.tw + autrijus\100autrijus.org + audreyt\100audreyt.org -cpan\100ton.iguana.be me-01\100ton.iguana.be +cpan\100ton.iguana.be me-01\100ton.iguana.be crt\100kiski.net perl\100ctweten.amsite.com -dairiki\100dairiki.org dairiki at dairiki.org +dairiki\100dairiki.org dairiki at dairiki.org dagolden\100cpan.org xdaveg\100gmail.com damian\100conway.org damian\100cs.monash.edu.au dan\100sidhe.org sugalsd\100lbcc.cc.or.us + sugalskd\100osshe.edu -daniel\100bitpusher.com daniel\100biz.bitpusher.com +daniel\100bitpusher.com daniel\100biz.bitpusher.com david.dyck\100fluke.com dcd\100tc.fluke.com -david\100kineticode.com david\100wheeler.com -+ david\100wheeler.net +david\100kineticode.com david\100wheeler.com ++ david\100wheeler.net dev-perl\100pimb.org knew-p5p\100pimb.org -djberg86\100attbi.com djberg96\100attbi.com +djberg86\100attbi.com djberg96\100attbi.com domo\100computer.org shouldbedomo\100mac.com + domo\100slipper.ip.lu -+ domo\100tcp.ip.lu ++ domo\100tcp.ip.lu dougm\100covalent.net dougm\100opengroup.org + dougm\100osf.org -dougw\100cpan.org doug_wilson\100intuit.com -dwegscheid\100qtm.net wegscd\100whirlpool.com -edwardp\100excitehome.net epeschko\100den-mdev1 -+ epeschko\100elmer.tci.com -+ esp5\100pge.com +dougw\100cpan.org doug_wilson\100intuit.com +dwegscheid\100qtm.net wegscd\100whirlpool.com +edwardp\100excitehome.net epeschko\100den-mdev1 ++ epeschko\100elmer.tci.com ++ esp5\100pge.com egf7\100columbia.edu efifer\100sanwaint.com -eggert\100twinsun.com eggert\100sea.sm.unisys.com +eggert\100twinsun.com eggert\100sea.sm.unisys.com fugazi\100zyx.net larrysh\100cpan.org -+ lshatzer\100islanddata.com ++ lshatzer\100islanddata.com -gbacon\100itsc.uah.edu gbacon\100adtrn-srv4.adtran.com +gbacon\100itsc.uah.edu gbacon\100adtrn-srv4.adtran.com gerberb\100zenez.com root\100devsys0.zenez.com -gfuji\100cpan.org g.psy.va\100gmail.com +gfuji\100cpan.org g.psy.va\100gmail.com +gerard\100ggoossen.net gerard\100tty.nl gibreel\100pobox.com stephen.zander\100interlock.mckesson.com + srz\100loopback gnat\100frii.com gnat\100prometheus.frii.com @@ -479,48 +480,48 @@ hansmu\100xs4all.nl hansm\100icgroup.nl + hans\100icgned.nl + hans\100icgroup.nl + hansm\100euronet.nl -+ hansm\100euro.net ++ hansm\100euro.net hio\100ymir.co.jp hio\100hio.jp -hops\100sco.com hops\100scoot.pdev.sco.com +hops\100sco.com hops\100scoot.pdev.sco.com -ingo_weinhold\100gmx.de bonefish\100cs.tu-berlin.de +ingo_weinhold\100gmx.de bonefish\100cs.tu-berlin.de -james\100mastros.biz theorb\100desert-island.me.uk -jand\100activestate.com jan.dubois\100ibm.net +james\100mastros.biz theorb\100desert-island.me.uk +jand\100activestate.com jan.dubois\100ibm.net japhy\100pobox.com japhy\100pobox.org + japhy\100perlmonk.org + japhy\100cpan.org -+ jeffp\100crusoe.net ++ jeffp\100crusoe.net jari.aalto\100poboxes.com jari.aalto\100cante.net -jarausch\100numa1.igpm.rwth-aachen.de helmutjarausch\100unknown -jasons\100cs.unm.edu jasons\100sandy-home.arc.unm.edu -jbuehler\100hekimian.com jhpb\100hekimian.com -jcromie\100100divsol.com jcromie\100cpan.org +jarausch\100numa1.igpm.rwth-aachen.de helmutjarausch\100unknown +jasons\100cs.unm.edu jasons\100sandy-home.arc.unm.edu +jbuehler\100hekimian.com jhpb\100hekimian.com +jcromie\100100divsol.com jcromie\100cpan.org + jim.cromie\100gmail.com -jidanni\100jidanni.org jidanni\100hoffa.dreamhost.com +jidanni\100jidanni.org jidanni\100hoffa.dreamhost.com jdhedden\100cpan.org jerry\100hedden.us + jdhedden\1001979.usna.com + jdhedden\100gmail.com + jdhedden\100yahoo.com -+ jhedden\100pn100-02-2-356p.corp.bloomberg.com -jeremy\100zawodny.com jzawodn\100wcnet.org ++ jhedden\100pn100-02-2-356p.corp.bloomberg.com +jeremy\100zawodny.com jzawodn\100wcnet.org jesse\100sig.bsh.com jesse\100ginger jfriedl\100yahoo.com jfriedl\100yahoo-inc.com -jfs\100fluent.com jfs\100jfs.fluent.com -jhannah\100omnihotels.com jay\100jays.net +jfs\100fluent.com jfs\100jfs.fluent.com +jhannah\100omnihotels.com jay\100jays.net jjore\100cpan.org twists\100gmail.com jns\100integration-house.com jns\100gellyfish.com + gellyfish\100gellyfish.com -john\100atlantech.com john\100titanic.atlantech.com -john\100johnwright.org john.wright\100hp.com -joseph\100cscaper.com joseph\1005sigma.com -joshua\100rodd.us jrodd\100pbs.org -jtobey\100john-edwin-tobey.org jtobey\100user1.channel1.com +john\100atlantech.com john\100titanic.atlantech.com +john\100johnwright.org john.wright\100hp.com +joseph\100cscaper.com joseph\1005sigma.com +joshua\100rodd.us jrodd\100pbs.org +jtobey\100john-edwin-tobey.org jtobey\100user1.channel1.com jpeacock\100rowman.com john.peacock\100havurah-software.org + jpeacock\100havurah-software.org -+ jpeacock\100dsl092-147-156.wdc1.dsl.speakeasy.net ++ jpeacock\100dsl092-147-156.wdc1.dsl.speakeasy.net jql\100accessone.com jql\100jql.accessone.com -jsm28\100hermes.cam.ac.uk jsm28\100cam.ac.uk +jsm28\100hermes.cam.ac.uk jsm28\100cam.ac.uk kane\100dwim.org kane\100xs4all.net + kane\100cpan.org @@ -528,67 +529,67 @@ kane\100dwim.org kane\100xs4all.net + jos\100dwim.org + jib\100ripe.net ken\100mathforum.org kenahoo\100gmail.com -+ ken.williams\100thomsonreuters.com ++ ken.williams\100thomsonreuters.com kroepke\100dolphin-services.de kay\100dolphin-services.de kstar\100wolfetech.com kstar\100cpan.org + kurt_starsinic\100ml.com -+ kstar\100www.chapin.edu -+ kstar\100chapin.edu ++ kstar\100www.chapin.edu ++ kstar\100chapin.edu larry\100wall.org lwall\100jpl-devvax.jpl.nasa.gov + lwall\100netlabs.com + larry\100netlabs.com + lwall\100sems.com + lwall\100scalpel.netlabs.com -laszlo.molnar\100eth.ericsson.se molnarl\100cdata.tvnet.hu -+ ml1050\100freemail.hu +laszlo.molnar\100eth.ericsson.se molnarl\100cdata.tvnet.hu ++ ml1050\100freemail.hu lewart\100uiuc.edu lewart\100vadds.cvm.uiuc.edu + d-lewart\100uiuc.edu -lstein\100cshl.org lstein\100formaggio.cshl.org -+ lstein\100genome.wi.mit.edu -lupe\100lupe-christoph.de lupe\100alanya.m.isar.de -lutherh\100stratcom.com lutherh\100infinet.com -mab\100wdl.loral.com markb\100rdcf.sm.unisys.com +lstein\100cshl.org lstein\100formaggio.cshl.org ++ lstein\100genome.wi.mit.edu +lupe\100lupe-christoph.de lupe\100alanya.m.isar.de +lutherh\100stratcom.com lutherh\100infinet.com +mab\100wdl.loral.com markb\100rdcf.sm.unisys.com marcel\100codewerk.com gr\100univie.ac.at -mark.p.lutz\100boeing.com tecmpl1\100triton.ca.boeing.com -marnix\100gmail.com pttesac!marnix!vanam +mark.p.lutz\100boeing.com tecmpl1\100triton.ca.boeing.com +marnix\100gmail.com pttesac!marnix!vanam mats\100sm6sxl.net mats\100sm5sxl.net mbarbon\100dsi.unive.it mattia.barbon\100libero.it mcmahon\100ibiblio.org mcmahon\100metalab.unc.edu -me\100davidglasser.net glasser\100tang-eleven-seventy-nine.mit.edu -merijnb\100iloquent.nl merijnb\100ms.com -+ merijnb\100iloquent.com +me\100davidglasser.net glasser\100tang-eleven-seventy-nine.mit.edu +merijnb\100iloquent.nl merijnb\100ms.com ++ merijnb\100iloquent.com merlyn\100stonehenge.com merlyn\100gadget.cscaper.com mgjv\100comdyn.com.au mgjv\100tradingpost.com.au -mlh\100swl.msd.ray.com webtools\100uewrhp03.msd.ray.com +mlh\100swl.msd.ray.com webtools\100uewrhp03.msd.ray.com michael.schroeder\100informatik.uni-erlangen.de mls\100suse.de mike\100stok.co.uk mike\100exegenix.com mjtg\100cam.ac.uk mjtg\100cus.cam.ac.uk -mikedlr\100tardis.ed.ac.uk mikedlr\100it.com.pl +mikedlr\100tardis.ed.ac.uk mikedlr\100it.com.pl moritz\100casella.verplant.org moritz\100faui2k3.org -+ moritz lenz ++ moritz lenz -neale\100VMA.TABNSW.COM.AU neale\100pucc.princeton.edu +neale\100VMA.TABNSW.COM.AU neale\100pucc.princeton.edu neeracher\100mac.com neeri\100iis.ee.ethz.ch -neil\100bowers.com neilb\100cre.canon.co.uk +neil\100bowers.com neilb\100cre.canon.co.uk nospam-abuse\100bloodgate.com tels\100bloodgate.com + perl_dummy\100bloodgate.com -ian.phillipps\100iname.com ian_phillipps\100yahoo.co.uk -+ ian\100dial.pipex.com +ian.phillipps\100iname.com ian_phillipps\100yahoo.co.uk ++ ian\100dial.pipex.com ignasi.roca\100fujitsu-siemens.com ignasi.roca\100fujitsu.siemens.es -ikegami\100adaelis.com eric\100fmdev10.(none) +ikegami\100adaelis.com eric\100fmdev10.(none) ilmari\100ilmari.org ilmari\100vesla.ilmari.org -illpide\100telecel.pt arbor\100al37al08.telecel.pt +illpide\100telecel.pt arbor\100al37al08.telecel.pt # see http://www.nntp.perl.org/group/perl.perl5.porters/2001/01/msg28925.html # ilya\100math.berkeley.edu ilya\100math.ohio-state.edu + nospam-abuse\100ilyaz.org -+ [9]ilya\100math.ohio-state.edu ++ [9]ilya\100math.ohio-state.edu ilya\100martynov.org ilya\100juil.nonet okamoto\100corp.hp.com okamoto\100hpcc123.corp.hp.com -orwant\100oreilly.com orwant\100media.mit.edu +orwant\100oreilly.com orwant\100media.mit.edu p5-authors\100crystalflame.net perl\100crystalflame.net + rs\100crystalflame.net @@ -596,53 +597,53 @@ p5-authors\100crystalflame.net perl\100crystalflame.net + coral\100moonlight.crystalflame.net + rs\100oregonnet.com paul.green\100stratus.com paul_greenvos\100vos.stratus.com -+ pgreen\100seussnt.stratus.com ++ pgreen\100seussnt.stratus.com paul.marquess\100btinternet.com paul_marquess\100yahoo.co.uk + paul.marquess\100ntlworld.com + paul.marquess\100openwave.com + pmarquess\100bfsec.bt.co.uk + pmqs\100cpan.org -+ paul\100paul-desktop.(none) -Pavel.Zakouril\100mff.cuni.cz root\100egg.karlov.mff.cuni.cz ++ paul\100paul-desktop.(none) +Pavel.Zakouril\100mff.cuni.cz root\100egg.karlov.mff.cuni.cz pcg\100goof.com schmorp\100schmorp.de perl\100cadop.com cdp\100hpescdp.fc.hp.com -perl\100greerga.m-l.org greerga\100m-l.org +perl\100greerga.m-l.org greerga\100m-l.org perl\100profvince.com vince\100profvince.com perl-rt\100wizbit.be p5p\100perl.wizbit.be # Maybe we should special case this to get real names out? -Peter.Dintelmann\100Dresdner-Bank.com peter.dintelmann\100dresdner-bank.com +Peter.Dintelmann\100Dresdner-Bank.com peter.dintelmann\100dresdner-bank.com # NOTE: There is an intentional trailing space in the line above pfeifer\100wait.de pfeifer\100charly.informatik.uni-dortmund.de -+ upf\100de.uu.net -rabbit\100rabbit.us rabbit+bugs\100rabbit.us ++ upf\100de.uu.net +rabbit\100rabbit.us rabbit+bugs\100rabbit.us phil\100perkpartners.com phil\100finchcomputer.com pimlott\100idiomtech.com andrew\100pimlott.net -+ pimlott\100abel.math.harvard.edu -pixel\100mandriva.com pixel\100mandrakesoft.com ++ pimlott\100abel.math.harvard.edu +pixel\100mandriva.com pixel\100mandrakesoft.com pne\100cpan.org philip.newton\100gmx.net + philip.newton\100datenrevision.de + pnewton\100gmx.de pprymmer\100factset.com pvhp\100forte.com public\100khwilliamson.com khw\100karl.(none) -+ khw\100khw-desktop.(none) ++ khw\100khw-desktop.(none) radu\100netsoft.ro rgreab\100fx.ro raphael.manfredi\100pobox.com raphael_manfredi\100grenoble.hp.com -renee.baecker\100smart-websolutions.de reneeb\100reneeb-desktop.(none) +renee.baecker\100smart-websolutions.de reneeb\100reneeb-desktop.(none) richard.foley\100rfi.net richard.foley\100t-online.de + richard.foley\100ubs.com + richard.foley\100ubsw.com rick\100consumercontact.com rick\100bort.ca + rick.delaney\100rogers.com + rick\100bort.ca -+ rick.delaney\100home.com ++ rick.delaney\100home.com rjbs\100cpan.org rjbs-perl-p5p\100lists.manxome.org -+ perl.p5p\100rjbs.manxome.org ++ perl.p5p\100rjbs.manxome.org rjk\100linguist.dartmouth.edu rjk\100linguist.thayer.dartmouth.edu + rjk-perl-p5p\100tamias.net -rjray\100redhat.com rjray\100uswest.com +rjray\100redhat.com rjray\100uswest.com rmgiroux\100acm.org rmgiroux\100hotmail.com -+ mgiroux\100bear.com ++ mgiroux\100bear.com rmbarker\100cpan.org rmb1\100cise.npl.co.uk + robin.barker\100npl.co.uk + rmb\100cise.npl.co.uk @@ -650,9 +651,9 @@ robertmay\100cpan.org rob\100themayfamily.me.uk roberto\100keltia.freenix.fr roberto\100eurocontrol.fr robin\100cpan.org robin\100kitsite.com roderick\100argon.org roderick\100gate.net -+ roderick\100ibcinc.com ++ roderick\100ibcinc.com rootbeer\100teleport.com rootbeer\100redcat.com -+ tomphoenix\100unknown ++ tomphoenix\100unknown schubiger\100cpan.org steven\100accognoscere.org + sts\100accognoscere.org + schubiger\100gmail.com @@ -660,10 +661,10 @@ schwern\100pobox.com schwern\100gmail.com + schwern\100athens.arena-i.com + schwern\100blackrider.aocn.com + schwern\100ool-18b93024.dyn.optonline.net -scotth\100sgi.com author scotth\100sgi.com 842220273 +0000 -+ schotth\100sgi.com -schwab\100suse.de schwab\100issan.informatik.uni-dortmund.de -+ schwab\100ls5.informatik.uni-dortmund.de +scotth\100sgi.com author scotth\100sgi.com 842220273 +0000 ++ schotth\100sgi.com +schwab\100suse.de schwab\100issan.informatik.uni-dortmund.de ++ schwab\100ls5.informatik.uni-dortmund.de sebastien\100aperghis.net maddingue\100free.fr + saper\100cpan.org shlomif\100vipe.technion.ac.il shlomif\100iglu.org.il @@ -675,8 +676,8 @@ simon\100simon-cozens.org simon\100pembro4.pmb.ox.ac.uk slaven\100rezic.de slaven.rezic\100berlin.de + srezic\100iconmobile.com + srezic\100cpan.org -+ eserte\100cs.tu-berlin.de -+ eserte\100vran.herceg.de ++ eserte\100cs.tu-berlin.de ++ eserte\100vran.herceg.de smcc\100mit.edu smcc\100ocf.berkeley.edu + smcc\100csua.berkeley.edu + alias\100mcs.com @@ -687,36 +688,36 @@ spider\100orb.nashua.nh.us spider\100web.zk3.dec.com + spider\100peano.zk3.dec.com + spider.boardman\100orb.nashua.nh.us> + spidb\100cpan.org -+ spider.boardman\100orb.nashua.nh.us -+ root\100peano.zk3.dec.com ++ spider.boardman\100orb.nashua.nh.us ++ root\100peano.zk3.dec.com spp\100ds.net spp\100psa.pencom.com + spp\100psasolar.colltech.com + spp\100spotter.yi.org stef\100mongueurs.net stef\100payrard.net + s.payrard\100wanadoo.fr -+ properler\100freesurf.fr -+ stef\100francenet.fr -sthoenna\100efn.org ysth\100raven.shiftboard.com ++ properler\100freesurf.fr ++ stef\100francenet.fr +sthoenna\100efn.org ysth\100raven.shiftboard.com tassilo.parseval\100post.rwth-aachen.de tassilo.von.parseval\100rwth-aachen.de -tchrist\100perl.com tchrist\100mox.perl.com -+ tchrist\100jhereg.perl.com -thomas.dorner\100start.de tdorner\100amadeus.net -tjenness\100cpan.org t.jenness\100jach.hawaii.edu -+ timj\100jach.hawaii.edu -tobez\100tobez.org tobez\100plab.ku.dk -tom\100compton.nu thh\100cyberscience.com -tom.horsley\100mail.ccur.com tom.horsley\100ccur.com -+ tom\100amber.ssd.hcsc.com - -vkonovalov\100lucent.com vkonovalov\100peterstar.ru -+ konovalo\100mail.wplus.net -+ vadim\100vkonovalov.ru -+ vkonovalov\100spb.lucent.com -+ vkonovalov\100alcatel-lucent.com - -whatever\100davidnicol.com davidnicol\100gmail.com -wolfgang.laun\100alcatel.at wolfgang.laun\100chello.at -+ wolfgang.laun\100thalesgroup.com -+ wolfgang.laun\100gmail.com -yath\100yath.de yath-perlbug\100yath.de +tchrist\100perl.com tchrist\100mox.perl.com ++ tchrist\100jhereg.perl.com +thomas.dorner\100start.de tdorner\100amadeus.net +tjenness\100cpan.org t.jenness\100jach.hawaii.edu ++ timj\100jach.hawaii.edu +tobez\100tobez.org tobez\100plab.ku.dk +tom\100compton.nu thh\100cyberscience.com +tom.horsley\100mail.ccur.com tom.horsley\100ccur.com ++ tom\100amber.ssd.hcsc.com + +vkonovalov\100lucent.com vkonovalov\100peterstar.ru ++ konovalo\100mail.wplus.net ++ vadim\100vkonovalov.ru ++ vkonovalov\100spb.lucent.com ++ vkonovalov\100alcatel-lucent.com + +whatever\100davidnicol.com davidnicol\100gmail.com +wolfgang.laun\100alcatel.at wolfgang.laun\100chello.at ++ wolfgang.laun\100thalesgroup.com ++ wolfgang.laun\100gmail.com +yath\100yath.de yath-perlbug\100yath.de diff --git a/Porting/cmpVERSION.pl b/Porting/cmpVERSION.pl index 8f908c8c21..f1189744c8 100644 --- a/Porting/cmpVERSION.pl +++ b/Porting/cmpVERSION.pl @@ -7,7 +7,7 @@ # with -d option, output the diffs too # with -x option, exclude dual-life modules (after all, there are tools # like core-cpan-diff that can already deal with them) -# With this option, one od the directories must be '.'. +# With this option, one of the directories must be '.'. # # Original by slaven@rezic.de, modified by jhi. # diff --git a/Porting/config.sh b/Porting/config.sh index b958755cb1..95e9efec49 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -49,8 +49,8 @@ api_subversion='0' api_version='11' api_versionstring='5.11.0' ar='ar' -archlib='/opt/perl/lib/5.11.1/i686-linux-64int' -archlibexp='/opt/perl/lib/5.11.1/i686-linux-64int' +archlib='/opt/perl/lib/5.11.2/i686-linux-64int' +archlibexp='/opt/perl/lib/5.11.2/i686-linux-64int' archname64='64int' archname='i686-linux-64int' archobjs='' @@ -77,6 +77,7 @@ ccversion='' cf_by='merijn' cf_email='yourname@yourhost.yourplace.com' cf_time='Wed Jan 23 09:43:56 CET 2008' +charbits='8' chgrp='' chmod='chmod' chown='' @@ -560,7 +561,7 @@ doublesize='8' drand01='drand48()' drand48_r_proto='0' dtrace='' -dynamic_ext='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash' +dynamic_ext='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash' eagain='EAGAIN' ebcdic='undef' echo='echo' @@ -575,7 +576,7 @@ endservent_r_proto='0' eunicefix=':' exe_ext='' expr='expr' -extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash Compress/Zlib Errno IO_Compress_Base IO_Compress_Zlib Module/Pluggable Test/Harness' +extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash Compress/Zlib Errno IO_Compress_Base IO_Compress_Zlib Module/Pluggable Test/Harness' extern_C='extern' extras='' fflushNULL='define' @@ -734,7 +735,7 @@ inc_version_list_init='0' incpath='' inews='' initialinstalllocation='/opt/perl/bin' -installarchlib='/opt/perl/lib/5.11.1/i686-linux-64int' +installarchlib='/opt/perl/lib/5.11.2/i686-linux-64int' installbin='/opt/perl/bin' installhtml1dir='' installhtml3dir='' @@ -742,13 +743,13 @@ installman1dir='/opt/perl/man/man1' installman3dir='/opt/perl/man/man3' installprefix='/opt/perl' installprefixexp='/opt/perl' -installprivlib='/opt/perl/lib/5.11.1' +installprivlib='/opt/perl/lib/5.11.2' installscript='/opt/perl/bin' -installsitearch='/opt/perl/lib/site_perl/5.11.1/i686-linux-64int' +installsitearch='/opt/perl/lib/site_perl/5.11.2/i686-linux-64int' installsitebin='/opt/perl/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='/opt/perl/lib/site_perl/5.11.1' +installsitelib='/opt/perl/lib/site_perl/5.11.2' installsiteman1dir='/opt/perl/man/man1' installsiteman3dir='/opt/perl/man/man3' installsitescript='/opt/perl/bin' @@ -767,7 +768,7 @@ issymlink='test -h' ivdformat='"Ld"' ivsize='8' ivtype='long long' -known_extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash' +known_extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash' ksh='' ld='cc' lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector' @@ -870,7 +871,7 @@ perl='' perl_patchlevel='34948' perladmin='yourname@yourhost.yourplace.com' perllibs='-lnsl -ldl -lm -lcrypt -lutil -lc' -perlpath='/opt/perl/bin/perl5.11.1' +perlpath='/opt/perl/bin/perl5.11.2' pg='pg' phostname='' pidtype='pid_t' @@ -879,8 +880,8 @@ pmake='' pr='' prefix='/opt/perl' prefixexp='/opt/perl' -privlib='/opt/perl/lib/5.11.1' -privlibexp='/opt/perl/lib/5.11.1' +privlib='/opt/perl/lib/5.11.2' +privlibexp='/opt/perl/lib/5.11.2' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -946,17 +947,17 @@ sig_num='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 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 6, 17, 29, 31, 0' sig_size='69' signal_t='void' -sitearch='/opt/perl/lib/site_perl/5.11.1/i686-linux-64int' -sitearchexp='/opt/perl/lib/site_perl/5.11.1/i686-linux-64int' +sitearch='/opt/perl/lib/site_perl/5.11.2/i686-linux-64int' +sitearchexp='/opt/perl/lib/site_perl/5.11.2/i686-linux-64int' sitebin='/opt/perl/bin' sitebinexp='/opt/perl/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/opt/perl/lib/site_perl/5.11.1' +sitelib='/opt/perl/lib/site_perl/5.11.2' sitelib_stem='/opt/perl/lib/site_perl' -sitelibexp='/opt/perl/lib/site_perl/5.11.1' +sitelibexp='/opt/perl/lib/site_perl/5.11.2' siteman1dir='/opt/perl/man/man1' siteman1direxp='/opt/perl/man/man1' siteman3dir='/opt/perl/man/man3' @@ -980,7 +981,7 @@ srand48_r_proto='0' srandom_r_proto='0' src='.' ssizetype='ssize_t' -startperl='#!/opt/perl/bin/perl5.11.1' +startperl='#!/opt/perl/bin/perl5.11.2' startsh='#!/bin/sh' static_ext=' ' stdchar='char' @@ -993,7 +994,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='1' +subversion='2' sysman='/usr/share/man/man1' tail='' tar='' @@ -1080,8 +1081,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.11.1' -version_patchlevel_string='version 11 subversion 1' +version='5.11.2' +version_patchlevel_string='version 11 subversion 2' versiononly='define' vi='' voidflags='15' @@ -1105,7 +1106,7 @@ config_arg8='-Dusedevel' config_arg9='-dE' PERL_REVISION=5 PERL_VERSION=11 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=11 PERL_API_SUBVERSION=0 diff --git a/Porting/config_H b/Porting/config_H index 88c21fe1ff..636d2234fa 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -952,8 +952,8 @@ * 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.11.1/i686-linux-64int" /**/ -#define ARCHLIB_EXP "/pro/lib/perl5/5.11.1/i686-linux-64int" /**/ +#define ARCHLIB "/pro/lib/perl5/5.11.2/i686-linux-64int" /**/ +#define ARCHLIB_EXP "/pro/lib/perl5/5.11.2/i686-linux-64int" /**/ /* ARCHNAME: * This symbol holds a string representing the architecture name. @@ -2594,8 +2594,8 @@ * 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.11.1" /**/ -#define PRIVLIB_EXP "/pro/lib/perl5/5.11.1" /**/ +#define PRIVLIB "/pro/lib/perl5/5.11.2" /**/ +#define PRIVLIB_EXP "/pro/lib/perl5/5.11.2" /**/ /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle @@ -2687,8 +2687,8 @@ * 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.11.1/i686-linux-64int" /**/ -#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.11.1/i686-linux-64int" /**/ +#define SITEARCH "/pro/lib/perl5/site_perl/5.11.2/i686-linux-64int" /**/ +#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.11.2/i686-linux-64int" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -2710,8 +2710,8 @@ * 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.11.1" /**/ -#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.11.1" /**/ +#define SITELIB "/pro/lib/perl5/site_perl/5.11.2" /**/ +#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.11.2" /**/ #define SITELIB_STEM "/pro/lib/perl5/site_perl" /**/ /* Size_t_size: @@ -4439,7 +4439,7 @@ * script to make sure (one hopes) that it runs with perl and not * some shell. */ -#define STARTPERL "#!/pro/bin/perl5.11.1" /**/ +#define STARTPERL "#!/pro/bin/perl5.11.2" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array diff --git a/Porting/how_to_write_a_perldelta.pod b/Porting/how_to_write_a_perldelta.pod index 66f7adcb20..5627812aca 100644 --- a/Porting/how_to_write_a_perldelta.pod +++ b/Porting/how_to_write_a_perldelta.pod @@ -333,6 +333,14 @@ here. The list of people to thank goes here. +You can find the list of committers and authors by: + + % git log v5.11.1..HEAD | perl -nlwe '$seen{$1}++ if /^Author: ([^<]*)/; END { print for sort keys %seen }' + +And how many files where changed by: + + % git diff v5.11.1..HEAD | diffstat + =item Reporting Bugs This doesn't usually need to be changed from the previous perldelta. diff --git a/Porting/release_managers_guide.pod b/Porting/release_managers_guide.pod index 5a9e1a6ab6..43b9646e5b 100644 --- a/Porting/release_managers_guide.pod +++ b/Porting/release_managers_guide.pod @@ -116,6 +116,12 @@ called perl. You can find Andreas' email address at: https://pause.perl.org/pause/query?ACTION=pause_04imprint +=item search.cpan.org + +Make sure that search.cpan.org knows that you're allowed to upload +perl distros. Contact Graham Barr to make sure that you're on the right +list. + =item CPAN mirror Some release engineering steps require a full mirror of the CPAN. @@ -476,7 +482,7 @@ Otherwise, run: $ ./perl -Ilib Porting/corelist.pl cpan This will chug for a while, possibly reporting various warnings about -badly-indexed CPABN modules unreltaed to the modules actually in core. +badly-indexed CPAN modules unrelated to the modules actually in core. Assuming all goes well, it will update F<dist/Module-CoreList/lib/Module/CoreList.pm>. @@ -842,7 +848,7 @@ see F<Porting/how_to_write_a_perldelta.pod>. You should be able to do this by just copying in a skeleton template and then doing a quick fix up of the version numbers, e.g. - $ cp -i Porting/perldelta_template pod/perl5102delta.pod + $ cp -i Porting/perldelta_template.pod pod/perl5102delta.pod $ (edit it) $ git add pod/perl5102delta.pod @@ -22,7 +22,7 @@ third-party modules. For an introduction to the language's features, see pod/perlintro.pod. For a discussion of the important changes in this release, see -pod/perl5100delta.pod. (This will also be installed as perldelta.pod). +pod/perl5113delta.pod. (This will also be installed as perldelta.pod). There are also many Perl books available, covering a wide variety of topics, from various publishers. See pod/perlbook.pod for more information. diff --git a/README.haiku b/README.haiku index ea3fedb434..2dafc41eca 100644 --- a/README.haiku +++ b/README.haiku @@ -22,9 +22,9 @@ The build procedure is completely standard: Make perl executable and create a symlink for libperl: chmod a+x /boot/common/bin/perl - cd /boot/common/lib; ln -s perl5/5.11.1/BePC-haiku/CORE/libperl.so . + cd /boot/common/lib; ln -s perl5/5.11.2/BePC-haiku/CORE/libperl.so . -Replace C<5.11.1> with your respective version of Perl. +Replace C<5.11.2> with your respective version of Perl. =head1 KNOWN PROBLEMS diff --git a/README.os2 b/README.os2 index a72e0a9694..c93661ccc7 100644 --- a/README.os2 +++ b/README.os2 @@ -618,7 +618,7 @@ C<set PERLLIB_PREFIX> in F<Config.sys>, see L<"PERLLIB_PREFIX">. =item Additional Perl modules - unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.11.1/ + unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.11.2/ Same remark as above applies. Additionally, if this directory is not one of directories on @INC (and @INC is influenced by C<PERLLIB_PREFIX>), you diff --git a/README.vms b/README.vms index 0e601bcc99..866255c8e4 100644 --- a/README.vms +++ b/README.vms @@ -27,7 +27,7 @@ you build or install. Also please note other changes in the current release by having a look at L<perldelta/VMS>. Also note that, as of Perl version 5.005 and later, an ANSI C compliant -compiler is required to build Perl. VAX C is *not* ANSI compliant, as it +compiler is required to build Perl. VAX C is I<not> ANSI compliant, as it died a natural death some time before the standard was set. Therefore VAX C will not compile Perl 5.005 or later. We are sorry about that. @@ -56,10 +56,6 @@ There are still some unimplemented system functions, and of course we could use modules implementing useful VMS system services, so if you'd like to lend a hand we'd love to have you. Join the Perl Porting Team Now! -There are issues with various versions of DEC C, so if you're not running a -relatively modern version, check the "DEC C issues" section later on in this -document. - =head2 Other required software for Compiling Perl on VMS In addition to VMS and DCL you will need two things: @@ -69,6 +65,9 @@ In addition to VMS and DCL you will need two things: =item 1 A C compiler. HP (formerly Compaq, more formerly DEC) C for VMS (VAX, Alpha, or Itanium). +Various ancient versions of DEC C had some caveats, so if you're using a +version older than 7.x on Alpha or Itanium or 6.x on VAX, you may need to +upgrade to get a successful build. =item 2 A make tool. @@ -85,7 +84,7 @@ You may also want to have on hand: =over 4 -=item 1 GUNZIP/GZIP.EXE for VMS +=item 1 GUNZIP/GZIP for VMS A de-compressor for *.gz and *.tgz files available from a number of web/ftp sites and is distributed on the OpenVMS Freeware CD-ROM @@ -108,26 +107,15 @@ A port of GNU tar is also available as part of the GNV package: http://h71000.www7.hp.com/opensource/gnv.html -=item 3 UNZIP.EXE for VMS +=item 3 UNZIP for VMS A combination decompressor and archive reader/writer for *.zip files. Unzip is available from a number of web/ftp sites. http://www.info-zip.org/UnZip.html http://www.hp.com/go/openvms/freeware/ - ftp://ftp.hp.com/pub/openvms/ ftp://ftp.process.com/vms-freeware/fileserv/ -=item 4 MOST - -Most is an optional pager that is convenient to use with perldoc (unlike -TYPE/PAGE, MOST can go forward and backwards in a document and supports -regular expression searching). Most builds with the slang -library on VMS. Most and slang are available from: - - ftp://space.mit.edu/pub/davis/ - ftp://ftp.process.com/vms-freeware/narnia/ - =item 5 GNU PATCH and DIFFUTILS for VMS Patches to Perl are usually distributed as GNU unified or contextual diffs. @@ -166,16 +154,16 @@ recent versions of vmstar (e.g. V3.4 or later). Contrary to advice provided with previous versions of Perl, do I<not> use the ODS-2 compatability qualifier. Instead, use a command like the following: - vmstar /extract/verbose perl-V^.XI^.I.tar + vmstar /extract/verbose perl-V^.XI^.II.tar or: - vmstar -xvf perl-5^.11^.1.tar + vmstar -xvf perl-5^.11^.2.tar Then rename the top-level source directory like so: - set security/protection=(o:rwed) perl-5^.11^.1.dir - rename perl-5^.11^.1.dir perl-5_11_1.dir + set security/protection=(o:rwed) perl-5^.11^.2.dir + rename perl-5^.11^.2.dir perl-5_11_2.dir The reason for this last step is that while filenames with multiple dots are generally supported by Perl on VMS, I<directory> names with multiple @@ -196,10 +184,6 @@ series of questions, and the answers to them (along with the capabilities of your C compiler and network stack) will determine how perl is custom built for your machine. -If you have multiple C compilers installed, you'll have your choice of -which one to use. Various older versions of DEC C had some caveats, so if -you're using a version older than 5.2, check the "DEC C Issues" section. - If you have any symbols or logical names in your environment that may interfere with the build or regression testing of perl then configure.com will try to warn you about them. If a logical name is causing @@ -328,7 +312,7 @@ This step is very important since there are always things that can go wrong somehow and yield a dysfunctional Perl for you. Testing is very easy, though, as there's a full test suite in the perl -distribution. To run the tests, enter the *exact* MMS line you used to +distribution. To run the tests, enter the I<exact> MMS line you used to compile Perl and add the word "test" to the end, like this: If the compile command was: @@ -359,7 +343,7 @@ If any tests fail, it means something is wrong with Perl, or at least with the particular module or feature that reported failure. If the test suite hangs (some tests can take upwards of two or three minutes, or more if you're on an especially slow machine, depending on your machine speed, so -don't be hasty), then the test *after* the last one displayed failed. Don't +don't be hasty), then the test I<after> the last one displayed failed. Don't install Perl unless you're confident that you're OK. Regardless of how confident you are, make a bug report to the VMSPerl mailing list. @@ -407,7 +391,7 @@ can be identified with "make --version". =head2 Cleaning up and starting fresh (optional) installing Perl on VMS If you need to recompile from scratch, you have to make sure you clean up -first. There is a procedure to do it--enter the *exact* MMS line you used +first. There is a procedure to do it--enter the I<exact> MMS line you used to compile and add "realclean" at the end, like this: if the compile command was: @@ -559,7 +543,7 @@ perlbug@perl.com. =head1 CAVEATS Probably the single biggest gotcha in compiling Perl is giving the wrong -switches to MMS/MMK when you build. Use *exactly* what the configure.com +switches to MMS/MMK when you build. Use I<exactly> what the configure.com script prints! The next big gotcha is directory depth. Perl can create directories four, @@ -579,10 +563,8 @@ a VAX or on Alpha versions of VMS prior to 7.2). But MakeMaker will not warn you if you start out building a module too deep in a directory. As noted above ODS-5 escape sequences such as ^. can break the perl -build. Solutions include renaming files and directories as needed or -being careful to use the -o switch or /ODS2 qualifier with latter -versions of the vmstar utility when unpacking perl or CPAN modules -on ODS-5 volumes. +build. Solutions include renaming files and directories as needed +when unpacking perl or CPAN modules on ODS-5 volumes. Be sure that the process that you use to build perl has a PGFLQ greater than 100000. Be sure to have a correct local time zone to UTC offset @@ -598,43 +580,6 @@ A final thing that causes trouble is leftover pieces from a failed build. If things go wrong make sure you do a "(MMK|MMS|make) realclean" before you rebuild. -=head2 DEC C issues with Perl on VMS - -Note to DEC C users: Some early versions (pre-5.2, some pre-4. If you're DEC -C 5.x or higher, with current patches if any, you're fine) of the DECCRTL -contained a few bugs which affect Perl performance: - -=over 4 - -=item - pipes - -Newlines are lost on I/O through pipes, causing lines to run together. -This shows up as RMS RTB errors when reading from a pipe. You can -work around this by having one process write data to a file, and -then having the other read the file, instead of the pipe. This is -fixed in version 4 of DEC C. - -=item - modf() - -The modf() routine returns a non-integral value for some values above -INT_MAX; the Perl "int" operator will return a non-integral value in -these cases. This is fixed in version 4 of DEC C. - -=item - ALPACRT ECO - -On the AXP, if SYSNAM privilege is enabled, the CRTL chdir() routine -changes the process default device and directory permanently, even -though the call specified that the change should not persist after -Perl exited. This is fixed by DEC CSC patch ALPACRT04_061 or later. -See also: - - http://www.itrc.hp.com/ - -=back - -Please note that in later versions "DEC C" may also be known as -"Compaq C". - =head2 GNU issues with Perl on VMS It has been a while since the GNU utilities such as GCC or GNU make @@ -652,10 +597,11 @@ format when either D_FLOAT or G_FLOAT is in use for doubles. Beginning with 5.8.0, Alpha builds now use IEEE floating point formats by default, which in VMS parlance are S_FLOAT for singles and T_FLOAT for doubles. IEEE is not available on VAX, so F_FLOAT and D_FLOAT remain the defaults for singles and -doubles respectively. The available non-default options are G_FLOAT on VAX -and D_FLOAT or G_FLOAT on Alpha. +doubles respectively. Itanium builds have always used IEEE by default. The +available non-default options are G_FLOAT on VAX and D_FLOAT or G_FLOAT on +Alpha or Itanium. -The use of IEEE on Alpha introduces NaN, infinity, and denormalization +The use of IEEE on Alpha or Itanium introduces NaN, infinity, and denormalization capabilities not available with D_FLOAT and G_FLOAT. When using one of those non-IEEE formats, silent underflow and overflow are emulated in the conversion of strings to numbers, but it is preferable to get the real thing by using @@ -676,58 +622,6 @@ compiler default on either VAX or Alpha, put in the option that you want in answer to the "Any additional cc flags?" question. For example, to obtain a G_FLOAT build on VAX, put in C</FLOAT=G_FLOAT>. -=head2 Multinet issues with Perl on VMS - -Prior to the release of Perl 5.8.0 it was noted that the regression -test for lib/Net/hostent (in file [.lib.Net]hostent.t) will fail owing -to problems with the hostent structure returned by C calls to either -gethostbyname() or gethostbyaddr() using DEC or Compaq C with a -Multinet TCP/IP stack. The problem was noted in Multinet 4.3A -using either Compaq C 6.5 or DEC C 6.0, and with Multinet 4.2A -using DEC C 5.2, but could easily affect other versions of Multinet. -Process Software Inc. has acknowledged a bug in the Multinet version -of UCX$IPC_SHR and has provided an ECO for it. The ECO is called -UCX_LIBRARY_EMULATION-010_A044 and is available from: - - http://www.multinet.process.com/eco.html - -As of this writing, the ECO is only available for Multinet versions -4.3A and later. You may determine the version of Multinet that you -are running using the command: - - multinet show /version - -from the DCL command prompt. - -If the ECO is unavailable for your version of Multinet and you are -unable to upgrade, you might try using Perl programming constructs -such as: - - $address = substr($gethostbyname_addr,0,4); - -to temporarily work around the problem, or if you are brave -and do not mind the possibility of breaking IPv6 addresses, -you might modify the pp_sys.c file to add an ad-hoc correction -like so: - - - --- pp_sys.c;1 Thu May 30 14:42:17 2002 - +++ pp_sys.c Thu May 30 12:54:02 2002 - @@ -4684,6 +4684,10 @@ - } - #endif - - + if (hent) { - + hent->h_length = 4; - + } - + - if (GIMME != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (hent) { - -then re-compile and re-test your perl. After the installation -of the Multinet ECO you ought to back out any such changes though. - =head1 Mailing Lists There are several mailing lists available to the Perl porter. For VMS @@ -753,7 +647,6 @@ Vmsperl pages on the web include: http://www.cpan.org/modules/by-module/VMS/ http://www.xray.mpe.mpg.de/mailing-lists/vmsperl/ http://www-ang.kfunigraz.ac.at/~binder/perl.html - http://lists.perl.org/showlist.cgi?name=vmsperl http://archive.develooper.com/vmsperl@perl.org/ http://h71000.www7.hp.com/openvms/products/ips/apache/csws_modperl.html diff --git a/README.win32 b/README.win32 index 231252a9e5..2a3a5b4afd 100644 --- a/README.win32 +++ b/README.win32 @@ -44,9 +44,18 @@ following compilers on the Intel x86 architecture: Borland C++ version 5.02 or later Microsoft Visual C++ version 2.0 or later MinGW with gcc gcc version 2.95.2 or later - -The last of these is a high quality freeware compiler. Use version -3.2.x or later for the best results with this compiler. + Gcc by mingw.org gcc version 2.95.2 or later + Gcc by mingw-w64.sf.net gcc version 4.4.3 or later + +Note that the last two of these are actually competing projects both +delivering complete gcc toolchain for MS Windows: +- http://mingw.org - delivers gcc toolchain targeting 32-bit Windows + platform. + Use version 3.2.x or later for the best results with this compiler. +- http://mingw-w64.sf.net - delivers gcc toolchain targeting both 64-bit + Windows and 32-bit Windows platforms (despite the project name "mingw-w64" + they are not only 64-bit oriented). They deliver the native gcc compilers + + cross-compilers that are also supported by perl's makefile. The Borland C++ and Microsoft Visual C++ compilers are also now being given away free. The Borland compiler is available as "Borland C++ Compiler Free @@ -57,11 +66,19 @@ as part of the ".NET Framework SDK") and is the same compiler that ships with "Visual C++ .NET 2003 Professional" or "Visual C++ 2005/2008 Professional" respectively. -This port can also be built on the Intel IA64 using: +This port can also be built on IA64/AMD64 using: Microsoft Platform SDK Nov 2001 (64-bit compiler and tools) + MinGW64 compiler (gcc version 4.4.3 or later) The MS Platform SDK can be downloaded from http://www.microsoft.com/. +The MinGW64 compiler is available at http://sourceforge.net/projects/mingw-w64. +The latter is actually a cross-compiler targeting Win64. There's also a trimmed +down compiler (no java, or gfortran) suitable for building perl available at: +http://svn.ali.as/cpan/users/kmx/strawberry_gcc-toolchain/ + +NOTE: If you're using a 32-bit compiler to build perl on a 64-bit Windows +operating system, then you should set the WIN64 environment variable to "undef". This port fully supports MakeMaker (the set of modules that is used to build extensions to perl). Therefore, you should be @@ -330,6 +347,9 @@ gcc-3.2.3. It can be downloaded here: Perl also compiles with earlier releases of gcc (2.95.2 and up). See below for notes about using earlier versions of MinGW/gcc. +And perl also compiles with gcc-4.3.0 and up, and perhaps even some of the +earlier 4.x.x versions. + You also need dmake. See L</"Make"> above on how to get it. =item MinGW release 1 with gcc @@ -396,7 +416,16 @@ may end up building against the installed perl's lib/CORE directory rather than the one being tested. You will have to make sure that CCTYPE is set correctly and that -CCHOME points to wherever you installed your compiler. +CCHOME points to wherever you installed your compiler. If building with +gcc-4.x.x, you'll also need to uncomment the assignment to GCC_4XX and +uncomment the assignment to the appropriate GCCHELPERDLL in the makefile.mk. + +If building with the cross-compiler provided by +mingw-w64.sourceforge.net you'll need to uncomment the line that sets +GCCCROSS in the makefile.mk. Do this only if it's the cross-compiler - ie +only if the bin folder doesn't contain a gcc.exe. (The cross-compiler +does not provide a gcc.exe, g++.exe, ar.exe, etc. Instead, all of these +executables are prefixed with 'x86_64-w64-mingw32-'.) The default value for CCHOME in the makefiles for Visual C++ may not be correct for some versions. Make sure the default exists @@ -478,6 +478,12 @@ Rethrows a previously caught exception. See L<perlguts/"Exception Handling">. # undef setservent #endif /* NETWARE */ +/* to avoid warnings: "xyz" redefined */ +#ifdef WIN32 +# undef popen +# undef pclose +#endif /* WIN32 */ + # undef socketpair # define mkdir PerlDir_mkdir diff --git a/autodoc.pl b/autodoc.pl index 042131e976..28ca96e309 100644 --- a/autodoc.pl +++ b/autodoc.pl @@ -25,10 +25,15 @@ use strict; # implicit interpreter context argument. # -my %apidocs; -my %gutsdocs; -my %docfuncs; -my %seenfuncs; +my %docs; +my %funcflags; +my %macro = ( + ax => 1, + items => 1, + ix => 1, + svtype => 1, + ); +my %missing; my $curheader = "Unknown section"; @@ -37,6 +42,11 @@ sub autodoc ($$) { # parse a file and extract documentation info my($in, $doc, $line); FUNC: while (defined($in = <$fh>)) { + if ($in =~ /^#\s*define\s+([A-Za-z_][A-Za-z_0-9]+)\(/ && + ($file ne 'embed.h' || $file ne 'proto.h')) { + $macro{$1} = $file; + next FUNC; + } if ($in=~ /^=head1 (.*)/) { $curheader = $1; next FUNC; @@ -58,17 +68,49 @@ DOC: $docs .= $doc; } $docs = "\n$docs" if $docs and $docs !~ /^\n/; + + # Check the consistency of the flags + my ($embed_where, $inline_where); + my ($embed_may_change, $inline_may_change); + + my $docref = delete $funcflags{$name}; + if ($docref and %$docref) { + $embed_where = $docref->{flags} =~ /A/ ? 'api' : 'guts'; + $embed_may_change = $docref->{flags} =~ /M/; + } else { + $missing{$name} = $file; + } if ($flags =~ /m/) { - if ($flags =~ /A/) { - $apidocs{$curheader}{$name} = [$flags, $docs, $ret, $file, @args]; + $inline_where = $flags =~ /A/ ? 'api' : 'guts'; + $inline_may_change = $flags =~ /x/; + + if (defined $embed_where && $inline_where ne $embed_where) { + warn "Function '$name' inconsistency: embed.fnc says $embed_where, Pod says $inline_where"; } - else { - $gutsdocs{$curheader}{$name} = [$flags, $docs, $ret, $file, @args]; + + if (defined $embed_may_change + && $inline_may_change ne $embed_may_change) { + my $message = "Function '$name' inconsistency: "; + if ($embed_may_change) { + $message .= "embed.fnc says 'may change', Pod does not"; + } else { + $message .= "Pod says 'may change', embed.fnc does not"; + } + warn $message; } + } elsif (!defined $embed_where) { + warn "Unable to place $name!\n"; + next; + } else { + $inline_where = $embed_where; + $flags .= 'x' if $embed_may_change; + @args = @{$docref->{args}}; + $ret = $docref->{retval}; } - else { - $docfuncs{$name} = [$flags, $docs, $ret, $file, $curheader, @args]; - } + + $docs{$inline_where}{$curheader}{$name} + = [$flags, $docs, $ret, $file, @args]; + if (defined $doc) { if ($doc =~ /^=(?:for|head)/) { $in = $doc; @@ -148,27 +190,8 @@ if (@ARGV) { or die "Couldn't chdir to '$workdir': $!"; } -my $file; -# glob() picks up docs from extra .c or .h files that may be in unclean -# development trees. -my $MANIFEST = do { - local ($/, *FH); - open FH, "MANIFEST" or die "Can't open MANIFEST: $!"; - <FH>; -}; - -for $file (($MANIFEST =~ /^(\S+\.c)\t/gm), ($MANIFEST =~ /^(\S+\.h)\t/gm)) { - open F, "< $file" or die "Cannot open $file for docs: $!\n"; - $curheader = "Functions in file $file\n"; - autodoc(\*F,$file); - close F or die "Error closing $file: $!\n"; -} - open IN, "embed.fnc" or die $!; -# walk table providing an array of components in each line to -# subroutine, printing the result - while (<IN>) { chomp; next if /^:/; @@ -181,38 +204,53 @@ while (<IN>) { my ($flags, $retval, $func, @args) = split /\s*\|\s*/, $_; - next unless $flags =~ /d/; next unless $func; s/\b(NN|NULLOK)\b\s+//g for @args; $func =~ s/\t//g; # clean up fields from embed.pl $retval =~ s/\t//; - my $docref = delete $docfuncs{$func}; - $seenfuncs{$func} = 1; - if ($docref and @$docref) { - if ($flags =~ /A/) { - $docref->[0].="x" if $flags =~ /M/; - $apidocs{$docref->[4]}{$func} = - [$docref->[0] . 'A', $docref->[1], $retval, $docref->[3], - @args]; - } else { - $gutsdocs{$docref->[4]}{$func} = - [$docref->[0], $docref->[1], $retval, $docref->[3], @args]; - } - } - else { - warn "no docs for $func\n" unless $seenfuncs{$func}; - } + $funcflags{$func} = { + flags => $flags, + retval => $retval, + args => \@args, + }; } -for (sort keys %docfuncs) { - # Have you used a full for apidoc or just a func name? - # Have you used Ap instead of Am in the for apidoc? - warn "Unable to place $_!\n"; +my $file; +# glob() picks up docs from extra .c or .h files that may be in unclean +# development trees. +my $MANIFEST = do { + local ($/, *FH); + open FH, "MANIFEST" or die "Can't open MANIFEST: $!"; + <FH>; +}; + +for $file (($MANIFEST =~ /^(\S+\.c)\t/gm), ($MANIFEST =~ /^(\S+\.h)\t/gm)) { + open F, "< $file" or die "Cannot open $file for docs: $!\n"; + $curheader = "Functions in file $file\n"; + autodoc(\*F,$file); + close F or die "Error closing $file: $!\n"; +} + +for (sort keys %funcflags) { + next unless $funcflags{$_}{flags} =~ /d/; + warn "no docs for $_\n" } -output('perlapi', <<'_EOB_', \%apidocs, <<'_EOE_'); +foreach (sort keys %missing) { + next if $macro{$_}; + # Heuristics for known not-a-function macros: + next if /^[A-Z]/; + next if /^dj?[A-Z]/; + + warn "Function '$_', documented in $missing{$_}, not listed in embed.fnc"; +} + +# walk table providing an array of components in each line to +# subroutine, printing the result + +output('perlapi', <<'_EOB_', $docs{api}, <<'_EOE_'); =head1 NAME perlapi - autogenerated documentation for the perl public API @@ -278,7 +316,7 @@ perlguts(1), perlxs(1), perlxstut(1), perlintern(1) _EOE_ -output('perlintern', <<'END', \%gutsdocs, <<'END'); +output('perlintern', <<'END', $docs{guts}, <<'END'); =head1 NAME perlintern - autogenerated documentation of purely B<internal> diff --git a/config_h.SH b/config_h.SH index ccb7f10ea0..ff4c86092a 100755 --- a/config_h.SH +++ b/config_h.SH @@ -2943,6 +2943,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #define BYTEORDER 0x$byteorder /* large digits for MSB */ #endif /* NeXT */ +/* CHARBITS: + * This symbol contains the size of a char, so that the C preprocessor + * can make decisions based on it. + */ +#define CHARBITS $charbits /**/ + /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. diff --git a/configure.com b/configure.com index d5ea93253c..2814b2eb7f 100644 --- a/configure.com +++ b/configure.com @@ -959,7 +959,7 @@ $ delete/symbol val $ delete/symbol dsym $ if f$type(usedebugging_perl) .nes. "" $ then -$ useperldebug = usedebugging_perl +$ DEBUGGING = usedebugging_perl $ delete/symbol usedebugging_perl $ endif $! @@ -2312,10 +2312,10 @@ $ echo "enables the -D switch, at the cost of some performance. It" $ echo "was mandatory on perl 5.005 and before on VMS, but is now" $ echo "optional. If you do not generally use it you should probably" $ echo "leave this off and gain a bit of extra speed." -$ bool_dflt = "y" -$ if f$type(useperldebug) .nes. "" +$ bool_dflt = "n" +$ if f$type(DEBUGGING) .nes. "" $ then -$ if f$extract(0,1,f$edit(useperldebug,"collapse,upcase")).eqs."N" .or. useperldebug .eqs. "undef" then bool_dflt="n" +$ if f$extract(0,1,f$edit(DEBUGGING,"collapse,upcase")).eqs."Y" .or. DEBUGGING .eqs. "define" then bool_dflt="y" $ endif $ rp = "Build a DEBUGGING version of Perl? [''bool_dflt'] " $ GOSUB myread @@ -5854,6 +5854,7 @@ $ WC "ccversion='" + ccversion + "'" $ WC "cf_by='" + cf_by + "'" $ WC "cf_email='" + cf_email + "'" $ WC "cf_time='" + cf_time + "'" +$ WC "charbits='8'" $ WC "config_args='" + config_args + "'" $ WC "config_sh='" + config_sh + "'" $ WC "cpp_stuff='" + cpp_stuff + "'" @@ -99,8 +99,9 @@ typedef struct jmpenv JMPENV; #define JMPENV_PUSH(v) \ STMT_START { \ - DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \ - (void*)&cur_env, (void*)PL_top_env)); \ + DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p at %s:%d\n", \ + (void*)&cur_env, (void*)PL_top_env, \ + __FILE__, __LINE__)); \ cur_env.je_prev = PL_top_env; \ OP_REG_TO_MEM; \ cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \ @@ -112,8 +113,9 @@ typedef struct jmpenv JMPENV; #define JMPENV_POP \ STMT_START { \ - DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n", \ - (void*)PL_top_env, (void*)cur_env.je_prev)); \ + DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p at %s:%d\n", \ + (void*)PL_top_env, (void*)cur_env.je_prev, \ + __FILE__, __LINE__)); \ assert(PL_top_env == &cur_env); \ PL_top_env = cur_env.je_prev; \ } STMT_END diff --git a/cpan/CPANPLUS-Dist-Build/lib/CPANPLUS/Dist/Build.pm b/cpan/CPANPLUS-Dist-Build/lib/CPANPLUS/Dist/Build.pm index a42e10ac3e..2bb5070815 100644 --- a/cpan/CPANPLUS-Dist-Build/lib/CPANPLUS/Dist/Build.pm +++ b/cpan/CPANPLUS-Dist-Build/lib/CPANPLUS/Dist/Build.pm @@ -30,7 +30,7 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; local $Params::Check::VERBOSE = 1; -$VERSION = '0.40'; +$VERSION = '0.44'; =pod @@ -375,47 +375,57 @@ sub _find_prereqs { my $prereqs = {}; - my $safe_ver = version->new('0.31_03'); + $prereqs = $dist->find_mymeta_requires() + if $dist->can('find_mymeta_requires'); - my $content; + if ( keys %$prereqs ) { + # Ugly hack + } + else { + my $safe_ver = version->new('0.31_03'); + my $content; + PREREQS: { + if ( version->new( $Module::Build::VERSION ) >= $safe_ver and IPC::Cmd->can_capture_buffer ) { + my @buildflags = $dist->_buildflags_as_list( $buildflags ); - if ( version->new( $Module::Build::VERSION ) >= $safe_ver and IPC::Cmd->can_capture_buffer ) { - my @buildflags = $dist->_buildflags_as_list( $buildflags ); + # Use the new Build action 'prereq_data' + my $run_perl = $conf->get_program('perlwrapper'); - # Use the new Build action 'prereq_data' - my $run_perl = $conf->get_program('perlwrapper'); - - unless ( scalar run( command => [$perl, $run_perl, BUILD->($dir), 'prereq_data', @buildflags], + unless ( scalar run( command => [$perl, $run_perl, BUILD->($dir), 'prereq_data', @buildflags], buffer => \$content, verbose => 0 ) - ) { + ) { error( loc( "Build 'prereq_data' failed: %1 %2", $!, $content ) ); - return; - } + #return; + } + else { + last PREREQS; + } - } - else { - my $file = File::Spec->catfile( $dir, '_build', 'prereqs' ); - return unless -f $file; + } + else { + my $file = File::Spec->catfile( $dir, '_build', 'prereqs' ); + return unless -f $file; - my $fh = FileHandle->new(); + my $fh = FileHandle->new(); - unless( $fh->open( $file ) ) { - error( loc( "Cannot open '%1': %2", $file, $! ) ); - return; - } + unless( $fh->open( $file ) ) { + error( loc( "Cannot open '%1': %2", $file, $! ) ); + return; + } - $content = do { local $/; <$fh> }; - } - - return unless $content; - my $bphash = eval $content; - return unless $bphash and ref $bphash eq 'HASH'; - foreach my $type ('requires', 'build_requires') { - next unless $bphash->{$type} and ref $bphash->{$type} eq 'HASH'; - $prereqs->{$_} = $bphash->{$type}->{$_} for keys %{ $bphash->{$type} }; + $content = do { local $/; <$fh> }; + } + } + + return unless $content; + my $bphash = eval $content; + return unless $bphash and ref $bphash eq 'HASH'; + foreach my $type ('requires', 'build_requires') { + next unless $bphash->{$type} and ref $bphash->{$type} eq 'HASH'; + $prereqs->{$_} = $bphash->{$type}->{$_} for keys %{ $bphash->{$type} }; + } } - # Temporary fix delete $prereqs->{'perl'}; diff --git a/cpan/CPANPLUS-Dist-Build/lib/CPANPLUS/Dist/Build/Constants.pm b/cpan/CPANPLUS-Dist-Build/lib/CPANPLUS/Dist/Build/Constants.pm index c04c247c6c..6fc6a18300 100644 --- a/cpan/CPANPLUS-Dist-Build/lib/CPANPLUS/Dist/Build/Constants.pm +++ b/cpan/CPANPLUS-Dist-Build/lib/CPANPLUS/Dist/Build/Constants.pm @@ -9,7 +9,7 @@ BEGIN { require Exporter; use vars qw[$VERSION @ISA @EXPORT]; - $VERSION = '0.40'; + $VERSION = '0.44'; @ISA = qw[Exporter]; @EXPORT = qw[ BUILD_DIR BUILD ]; } diff --git a/cpan/CPANPLUS/lib/CPANPLUS.pm b/cpan/CPANPLUS/lib/CPANPLUS.pm index c10d0c10b1..5421106326 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS.pm @@ -13,7 +13,7 @@ BEGIN { use vars qw( @EXPORT @ISA $VERSION ); @EXPORT = qw( shell fetch get install ); @ISA = qw( Exporter ); - $VERSION = "0.89_06"; #have to hardcode or cpan.org gets unhappy + $VERSION = "0.89_09"; #have to hardcode or cpan.org gets unhappy } ### purely for backward compatibility, so we can call it from the commandline: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm b/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm index 1702f3573b..a599e5429e 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm @@ -729,6 +729,15 @@ sub parse_module { ### let's start putting the blame somewhere } else { + # Lets not give up too easily. There is one last chance + # http://perlmonks.org/?node_id=805957 + # This should catch edge-cases where the package name + # is unrelated to the modules it contains. + + my ($modobj) = grep { $_->package_name eq $mod } + $self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], ); + return $modobj if IS_MODOBJ->( module => $modobj ); + unless( $author ) { error( loc( "'%1' does not contain an author part", $mod ) ); } diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Config.pm b/cpan/CPANPLUS/lib/CPANPLUS/Config.pm index 28f4fb6ef0..bd5373b513 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Config.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Config.pm @@ -344,7 +344,8 @@ C<Build.PL> file if both are present. Defaults to 'true'. =cut - $Conf->{'conf'}->{'prefer_makefile'} = 1; + $Conf->{'conf'}->{'prefer_makefile'} = + ( $] >= 5.010001 ? 0 : 1 ); =item prereqs diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm index b6ffdbe478..551b8ec405 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm @@ -293,23 +293,70 @@ and versions required. sub find_configure_requires { my $self = shift; my $mod = $self->parent; - my %hash = @_; + my $meth = 'configure_requires'; + + ### the prereqs as we have them now + my @args = ( + defaults => $mod->status->$meth || {}, + keys => [ $meth ], + ); + + ### the default file to use, which may be overriden + push @args, ( file => META_YML->( $mod->status->extract ) ) + if defined $mod->status->extract; + + my $href = $self->_prereqs_from_meta_file( @args, @_ ); + + ### and store it in the module + $mod->status->$meth( $href ); + + return { %$href }; +} + +sub find_mymeta_requires { + my $self = shift; + my $mod = $self->parent; + my $meth = 'prereqs'; - my $meta; + ### the prereqs as we have them now + my @args = ( + defaults => $mod->status->$meth || {}, + keys => [qw|requires build_requires|], + ); + + ### the default file to use, which may be overriden + push @args, ( file => MYMETA_YML->( $mod->status->extract ) ) + if defined $mod->status->extract; + + my $href = $self->_prereqs_from_meta_file( @args, @_ ); + + ### and store it in the module + $mod->status->$meth( $href ); + + return { %$href }; +} + +sub _prereqs_from_meta_file { + my $self = shift; + my $mod = $self->parent; + my %hash = @_; + + my( $meta, $defaults, $keys ); my $tmpl = { ### check if we have an extract path. if not, we ### get 'undef value' warnings from file::spec - file => { default => do { defined $mod->status->extract + file => { default => do { defined $mod->status->extract ? META_YML->( $mod->status->extract ) : '' }, - store => \$meta, - }, + store => \$meta, + }, + defaults => { required => 1, default => {}, strict_type => 1, + store => \$defaults }, + keys => { required => 1, default => [], strict_type => 1, + store => \$keys }, }; check( $tmpl, \%hash ) or return; - ### default is an empty hashref - my $configure_requires = $mod->status->configure_requires || {}; - ### if there's a meta file, we read it; if( -e $meta ) { @@ -319,22 +366,21 @@ sub find_configure_requires { unless( $doc ) { error(loc( "Could not read %1: '%2'", $meta, $@ )); - return $configure_requires; # Causes problems if we don't return a hashref + return $defaults; } - ### read the configure_requires key, make sure not to throw + ### read the keys now, make sure not to throw ### away anything that was already added - $configure_requires = { - %$configure_requires, - %{ $doc->{'configure_requires'} }, - } if $doc->{'configure_requires'}; + for my $key ( @$keys ) { + $defaults = { + %$defaults, + %{ $doc->{$key} }, + } if $doc->{ $key }; + } } - ### and store it in the module - $mod->status->configure_requires( $configure_requires ); - ### and return a copy - return \%{$configure_requires}; + return \%{ $defaults }; } =head2 $bool = $dist->_resolve_prereqs( ... ) diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm index 21852ff343..4249ecc741 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm @@ -465,6 +465,13 @@ sub _find_prereqs { }; my $args = check( $tmpl, \%hash ) or return; + + ### see if we got prereqs from MYMETA + my $prereqs = $dist->find_mymeta_requires(); + + ### we found some prereqs, we'll trust MYMETA + ### but we do need to run it through the callback + return $cb->_callbacks->filter_prereqs->( $cb, $prereqs ) if keys %$prereqs; my $fh = FileHandle->new(); unless( $fh->open( $file ) ) { diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm index 8cd6a82461..0715ba9c5e 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm @@ -42,7 +42,7 @@ use vars qw[@ISA $VERSION]; CPANPLUS::Internals::Report ]; -$VERSION = "0.89_06"; +$VERSION = "0.89_09"; =pod diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm index 1d05c98fe4..1a38200dfb 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm @@ -149,6 +149,11 @@ use constant META_YML => sub { return @_ : 'META.yml'; }; +use constant MYMETA_YML => sub { return @_ + ? File::Spec->catfile( @_, 'MYMETA.yml' ) + : 'MYMETA.yml'; + }; + use constant BLIB => sub { return @_ ? File::Spec->catfile(@_, 'blib') : 'blib'; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm index 6ad577c016..59a41a6083 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm @@ -145,12 +145,13 @@ use constant TEST_FAIL_STAGE use constant MISSING_PREREQS_LIST => sub { my $buffer = shift; + my $last = ( split /\[ERROR\] .+? MAKE TEST/, $buffer )[-1]; my @list = map { s/.pm$//; s|/|::|g; $_ } - ($buffer =~ + ($last =~ m/\bCan\'t locate (\S+) in \@INC/g); ### make sure every missing prereq is only - ### listed ones + ### listed once { my %seen; @list = grep { !$seen{$_}++ } @list } diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm index 04291224f7..eaa9f80d47 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm @@ -26,7 +26,7 @@ local $Data::Dumper::Indent = 1; # for dumpering from ! BEGIN { use vars qw[ $VERSION @ISA ]; @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; - $VERSION = "0.89_06"; + $VERSION = "0.89_09"; } load CPANPLUS::Shell; diff --git a/cpan/Encode/AUTHORS b/cpan/Encode/AUTHORS index 71e1cc3c7a..a470e57f65 100644 --- a/cpan/Encode/AUTHORS +++ b/cpan/Encode/AUTHORS @@ -17,14 +17,15 @@ Benjamin Goldberg <goldbb2@earthlink.net> Bjoern Hoehrmann <derhoermi@gmx.net> Bjoern Jacke <debianbugs@j3e.de> Chris Nandor <pudge@pobox.com> -Curtis Jewell <csjewell@cpan.org> Craig A. Berry <craigberry@mac.com> +Curtis Jewell <csjewell@cpan.org> Dan Kogai <dankogai@dan.co.jp> Dave Evans <dave@rudolf.org.uk> Deng Liu <dengliu@ntu.edu.tw> Dominic Dunlop <domo@computer.org> Elizabeth Mattijsen <liz@dijkmat.nl> Gerrit P. Haase <gp@familiehaase.de> +Gisle Aas <gisle@ActiveState.com> Graham Barr <gbarr@pobox.com> Gurusamy Sarathy <gsar@activestate.com> H.Merijn Brand <h.m.brand@xs4all.nl> @@ -59,5 +60,6 @@ Steve Hay <steve.hay@uk.radan.com> Steve Peters <steve@fisharerojo.org> Tatsuhiko Miyagawa <miyagawa@bulknews.net> Tels <perl_dummy@bloodgate.com> +Tony Cook <tony@develop-help.com> Vadim Konovalov <vkonovalov@peterstar.ru> Yitzchak Scott-Thoennes <sthoenna@efn.org> diff --git a/cpan/Encode/Byte/Byte.pm b/cpan/Encode/Byte/Byte.pm index 3ea9035b7b..d105aa27cc 100644 --- a/cpan/Encode/Byte/Byte.pm +++ b/cpan/Encode/Byte/Byte.pm @@ -2,7 +2,7 @@ package Encode::Byte; use strict; use warnings; use Encode; -our $VERSION = do { my @r = ( q$Revision: 2.3 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; +our $VERSION = do { my @r = ( q$Revision: 2.4 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; use XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); @@ -55,7 +55,7 @@ supported are as follows. viscii # all cp* are also available as ibm-*, ms-*, and windows-* - # also see L<http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp> + # also see L<http://msdn.microsoft.com/en-us/library/aa752010%28VS.85%29.aspx> cp424 cp437 diff --git a/cpan/Encode/CN/CN.pm b/cpan/Encode/CN/CN.pm index 9f120fb7f1..830f34507d 100644 --- a/cpan/Encode/CN/CN.pm +++ b/cpan/Encode/CN/CN.pm @@ -7,7 +7,7 @@ BEGIN { use strict; use warnings; use Encode; -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 XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); @@ -65,11 +65,7 @@ mean C<euc-cn> encodings. To fix that, C<gb2312> is aliased to C<euc-cn>. Use C<gb2312-raw> when you really mean it. The ASCII region (0x00-0x7f) is preserved for all encodings, even though -this conflicts with mappings by the Unicode Consortium. See - -L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en> - -to find out why it is implemented that way. +this conflicts with mappings by the Unicode Consortium. =head1 SEE ALSO diff --git a/cpan/Encode/Changes b/cpan/Encode/Changes index dcd738410b..6c045f7262 100644 --- a/cpan/Encode/Changes +++ b/cpan/Encode/Changes @@ -1,12 +1,33 @@ # Revision history for Perl extension Encode. # -# $Id: Changes,v 2.37 2009/09/06 14:32:21 dankogai Exp dankogai $ -$Revision: 2.37 $ $Date: 2009/09/06 14:32:21 $ +# $Id: Changes,v 2.38 2009/11/16 14:08:13 dankogai Exp dankogai $ +$Revision: 2.38 $ $Date: 2009/11/16 14:08:13 $ +! Encode.xs + Addressed: Encode memory corruption [perl #70528] + Message-Id: <alpine.LFD.2.00.0911152328070.9483@ein.m-l.org> +! t/Unicode.t Unicode/Unicode.xs + Patched: #51263: set magic is not applied when modifying encode arguments + http://rt.cpan.org/Ticket/Display.html?id=51263 +! Encode.xs + Patched: #51204: Callback CHECK not supported for UTF-8 decoder/encoder + http://rt.cpan.org/Ticket/Display.html?id=51204 +! Byte/Byte.pm CN/CN.pm Changes JP/JP.pm KR/KR.pm TW/TW.pm + Unicode/Unicode.pm bin/enc2xs lib/Encode/Supported.pod + Fix URLs + http://rt.cpan.org/Ticket/Display.html?id=49776 +! t/CJKT.t t/guess.t t/perlio.t t/piconv.t + $PERL_CORE trick is now off for perl 5.11 or better. + Message-Id: <b77c1dce0909070245s59b294bq8a8a8166e7342793@mail.gmail.com> + Message-Id: <E7FADA6C-D5A7-4ECA-BE4C-85911A97677E@dan.co.jp> + Message-Id: <20090907154908.GS60303@plum.flirble.org> + Message-Id: <20090907161509.GN8057@iabyn.com> + +2.37 2009/09/06 14:32:21 ! Encode.xs fixed: compilation failure on compilers not supporting C99 http://rt.cpan.org/Ticket/Display.html?id=49466 -2.37 2009/09/06 09:03:07 +2.36 2009/09/06 09:03:07 ! Encode.xs fixed: 'find_encoding("utf8")->decode(undef)' causes segmentation fault http://rt.cpan.org/Ticket/Display.html?id=49462 @@ -518,7 +539,7 @@ $Revision: 2.37 $ $Date: 2009/09/06 14:32:21 $ 1.99 2003/12/29 02:47:16 ! Unicode/Unicode.xs find_encoding("UTF-16BE")->encode("abc") now null terminates - http://www.mail-archive.com/perl5-porters@perl.org/msg69766.html + http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2003-10/threads.html#00258 ! Encode.pm prototype bug in decode_utf8() fixed Message-Id: <600A4CDA-F004-11D7-B570-000393AE4244@dan.co.jp> diff --git a/cpan/Encode/Encode.pm b/cpan/Encode/Encode.pm index 749c8f9704..267642c29f 100644 --- a/cpan/Encode/Encode.pm +++ b/cpan/Encode/Encode.pm @@ -1,10 +1,10 @@ # -# $Id: Encode.pm,v 2.37 2009/09/06 14:30:32 dankogai Exp $ +# $Id: Encode.pm,v 2.38 2009/11/16 14:08:01 dankogai Exp $ # package Encode; use strict; use warnings; -our $VERSION = sprintf "%d.%02d", q$Revision: 2.37 $ =~ /(\d+)/g; +our $VERSION = sprintf "%d.%02d", q$Revision: 2.38 $ =~ /(\d+)/g; sub DEBUG () { 0 } use XSLoader (); XSLoader::load( __PACKAGE__, $VERSION ); diff --git a/cpan/Encode/Encode.xs b/cpan/Encode/Encode.xs index e5f4c9a32d..5b8d84c25f 100644 --- a/cpan/Encode/Encode.xs +++ b/cpan/Encode/Encode.xs @@ -1,5 +1,5 @@ /* - $Id: Encode.xs,v 2.16 2009/09/06 14:32:21 dankogai Exp dankogai $ + $Id: Encode.xs,v 2.17 2009/11/16 14:08:13 dankogai Exp dankogai $ */ #define PERL_NO_GET_CONTEXT @@ -68,7 +68,7 @@ do_fallback_cb(pTHX_ UV ch, SV *fallback_cb) { dSP; int argc; - SV *temp, *retval; + SV *retval = newSVpv("",0); ENTER; SAVETMPS; PUSHMARK(sp); @@ -79,13 +79,10 @@ do_fallback_cb(pTHX_ UV ch, SV *fallback_cb) if (argc != 1){ croak("fallback sub must return scalar!"); } - temp = newSVsv(POPs); + sv_catsv(retval, POPs); PUTBACK; FREETMPS; LEAVE; - retval = newSVpv("",0); - sv_catsv(retval, temp); - SvREFCNT_dec(temp); return retval; } @@ -199,6 +196,7 @@ encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src, : newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04"UVxf"}" : check & ENCODE_HTMLCREF ? "&#%" UVuf ";" : "&#x%" UVxf ";", (UV)ch); + SvUTF8_off(subchar); /* make sure no decoded string gets in */ sdone += slen + clen; ddone += dlen + SvCUR(subchar); sv_catsv(dst, subchar); @@ -401,19 +399,26 @@ MODULE = Encode PACKAGE = Encode::utf8 PREFIX = Method_ PROTOTYPES: DISABLE void -Method_decode_xs(obj,src,check = 0) +Method_decode_xs(obj,src,check_sv = &PL_sv_no) SV * obj SV * src -int check +SV * check_sv PREINIT: STRLEN slen; U8 *s; U8 *e; SV *dst; bool renewed = 0; + int check; CODE: { dSP; ENTER; SAVETMPS; + if (SvROK(check_sv)) { + croak("UTF-8 decoder doesn't support callback CHECK"); + } + else { + check = SvIV(check_sv); + } if (src == &PL_sv_undef) src = newSV(0); s = (U8 *) SvPV(src, slen); e = (U8 *) SvEND(src); @@ -464,18 +469,25 @@ CODE: } void -Method_encode_xs(obj,src,check = 0) +Method_encode_xs(obj,src,check_sv = &PL_sv_no) SV * obj SV * src -int check +SV * check_sv PREINIT: STRLEN slen; U8 *s; U8 *e; SV *dst; bool renewed = 0; + int check; CODE: { + if (SvROK(check_sv)) { + croak("UTF-8 encoder doesn't support callback CHECK"); + } + else { + check = SvIV(check_sv); + } if (src == &PL_sv_undef) src = newSV(0); s = (U8 *) SvPV(src, slen); e = (U8 *) SvEND(src); diff --git a/cpan/Encode/JP/JP.pm b/cpan/Encode/JP/JP.pm index e78e54d052..4251170c56 100644 --- a/cpan/Encode/JP/JP.pm +++ b/cpan/Encode/JP/JP.pm @@ -7,7 +7,7 @@ BEGIN { use strict; use warnings; use Encode; -our $VERSION = do { my @r = ( q$Revision: 2.3 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; +our $VERSION = do { my @r = ( q$Revision: 2.4 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; use XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); @@ -86,11 +86,7 @@ in order to preserve text layout as much as possible. =head1 BUGS The ASCII region (0x00-0x7f) is preserved for all encodings, even -though this conflicts with mappings by the Unicode Consortium. See - -L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en> - -to find out why it is implemented that way. +though this conflicts with mappings by the Unicode Consortium. =head1 SEE ALSO diff --git a/cpan/Encode/KR/KR.pm b/cpan/Encode/KR/KR.pm index 8cb2c63b16..cf2c1174e4 100644 --- a/cpan/Encode/KR/KR.pm +++ b/cpan/Encode/KR/KR.pm @@ -7,7 +7,7 @@ BEGIN { use strict; use warnings; use Encode; -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 XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); @@ -60,11 +60,7 @@ mean "cp949" encodings. To fix that, the following aliases are set; qr/ks_c_5601-1987$/i => '"cp949"' The ASCII region (0x00-0x7f) is preserved for all encodings, even -though this conflicts with mappings by the Unicode Consortium. See - -L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en> - -to find out why it is implemented that way. +though this conflicts with mappings by the Unicode Consortium. =head1 SEE ALSO diff --git a/cpan/Encode/META.yml b/cpan/Encode/META.yml index 85a3cd0d8b..70090afc02 100644 --- a/cpan/Encode/META.yml +++ b/cpan/Encode/META.yml @@ -1,6 +1,6 @@ --- #YAML:1.0 name: Encode -version: 2.37 +version: 2.38 abstract: ~ author: [] license: unknown @@ -14,7 +14,7 @@ no_index: directory: - t - inc -generated_by: ExtUtils::MakeMaker version 6.54 +generated_by: ExtUtils::MakeMaker version 6.55_02 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 diff --git a/cpan/Encode/TW/TW.pm b/cpan/Encode/TW/TW.pm index ffaa844204..c30499bee1 100644 --- a/cpan/Encode/TW/TW.pm +++ b/cpan/Encode/TW/TW.pm @@ -7,7 +7,7 @@ BEGIN { use strict; use warnings; use Encode; -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 XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); @@ -66,11 +66,7 @@ manipulation, please use C<EUC-TW> in L<Encode::HanExtra>, which contains planes 1-7. The ASCII region (0x00-0x7f) is preserved for all encodings, even -though this conflicts with mappings by the Unicode Consortium. See - -L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en> - -to find out why it is implemented that way. +though this conflicts with mappings by the Unicode Consortium. =head1 SEE ALSO diff --git a/cpan/Encode/Unicode/Unicode.pm b/cpan/Encode/Unicode/Unicode.pm index 16982bbb16..f71567c619 100644 --- a/cpan/Encode/Unicode/Unicode.pm +++ b/cpan/Encode/Unicode/Unicode.pm @@ -4,7 +4,7 @@ use strict; use warnings; no warnings 'redefine'; -our $VERSION = do { my @r = ( q$Revision: 2.6 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; +our $VERSION = do { my @r = ( q$Revision: 2.7 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; use XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); @@ -259,7 +259,7 @@ Consider that "division by zero" of Encode :) L<Encode>, L<Encode::Unicode::UTF7>, L<http://www.unicode.org/glossary/>, L<http://www.unicode.org/unicode/faq/utf_bom.html>, -RFC 2781 L<http://rfc.net/rfc2781.html>, +RFC 2781 L<http://www.ietf.org/rfc/rfc2781.txt>, The whole Unicode standard L<http://www.unicode.org/unicode/uni2book/u2.html> diff --git a/cpan/Encode/Unicode/Unicode.xs b/cpan/Encode/Unicode/Unicode.xs index 1f041d4240..d8ef569515 100644 --- a/cpan/Encode/Unicode/Unicode.xs +++ b/cpan/Encode/Unicode/Unicode.xs @@ -1,5 +1,5 @@ /* - $Id: Unicode.xs,v 2.5 2009/02/01 13:14:41 dankogai Exp $ + $Id: Unicode.xs,v 2.6 2009/11/16 14:08:13 dankogai Exp dankogai $ */ #define PERL_NO_GET_CONTEXT @@ -377,5 +377,7 @@ CODE: if (!temp_result) shrink_buffer(result); + SvSETMAGIC(utf8); + XSRETURN(1); } diff --git a/cpan/Encode/bin/enc2xs b/cpan/Encode/bin/enc2xs index 233ca546e7..773c0a09fb 100644..100755 --- a/cpan/Encode/bin/enc2xs +++ b/cpan/Encode/bin/enc2xs @@ -10,7 +10,7 @@ use warnings; use Getopt::Std; use Config; my @orig_ARGV = @ARGV; -our $VERSION = do { my @r = (q$Revision: 2.6 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 2.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # These may get re-ordered. # RAW is a do_now as inserted by &enter @@ -1356,7 +1356,7 @@ L<http://www.icu-project.org/> =item * ICU Character Mapping Tables -L<http://www.icu-project.org/charset/> +L<http://site.icu-project.org/charts/charset> =item * diff --git a/cpan/Encode/bin/piconv b/cpan/Encode/bin/piconv index 9fdebd193c..9fdebd193c 100644..100755 --- a/cpan/Encode/bin/piconv +++ b/cpan/Encode/bin/piconv diff --git a/cpan/Encode/bin/ucm2table b/cpan/Encode/bin/ucm2table index 66e63fcdb9..66e63fcdb9 100644..100755 --- a/cpan/Encode/bin/ucm2table +++ b/cpan/Encode/bin/ucm2table diff --git a/cpan/Encode/bin/ucmsort b/cpan/Encode/bin/ucmsort index 3e037dc02b..3e037dc02b 100644..100755 --- a/cpan/Encode/bin/ucmsort +++ b/cpan/Encode/bin/ucmsort diff --git a/cpan/Encode/bin/unidump b/cpan/Encode/bin/unidump index ae0da30852..ae0da30852 100644..100755 --- a/cpan/Encode/bin/unidump +++ b/cpan/Encode/bin/unidump diff --git a/cpan/Encode/lib/Encode/Supported.pod b/cpan/Encode/lib/Encode/Supported.pod index 431bb7750b..e84faafd9e 100644 --- a/cpan/Encode/lib/Encode/Supported.pod +++ b/cpan/Encode/lib/Encode/Supported.pod @@ -589,7 +589,7 @@ for example) it is beyond the power of words to describe the way HTML browsers encode non-C<ASCII> form data. To get a general impression, visit -L<http://ppewww.ph.gla.ac.uk/~flavell/charset/form-i18n.html>. +L<http://www.alanflavell.org.uk/charset/form-i18n.html>. While encoding of form data has stabilized for C<UTF-8> encoded pages (at least IE 5/6, NS 6, and Opera 6 behave consistently), be sure to expect fun (and cross-browser discrepancies) with C<UTF-16> encoded @@ -817,7 +817,7 @@ L<http://www.iso.ch/> =item RFC Request For Comments -- need I say more? -L<http://www.rfc-editor.org/>, L<http://www.rfc.net/>, +L<http://www.rfc-editor.org/>, L<http://www.ietf.org/rfc.html>, L<http://www.faqs.org/rfcs/> =item UC @@ -850,7 +850,7 @@ vs. vendor mappings. =item CJK.inf -L<http://www.oreilly.com/people/authors/lunde/cjk_inf.html> +L<http://examples.oreilly.com/cjkvinfo/doc/cjk.inf> Somewhat obsolete (last update in 1996), but still useful. Also try @@ -893,7 +893,7 @@ to better support CJKV languages/scripts in all the areas of information processing. To purchase this book, visit -L<http://www.oreilly.com/catalog/cjkvinfo/> +L<http://oreilly.com/catalog/9780596514471/> or your favourite bookstore. =back diff --git a/cpan/Encode/t/Unicode.t b/cpan/Encode/t/Unicode.t index aa80899ab3..d6dd1ec1b9 100644 --- a/cpan/Encode/t/Unicode.t +++ b/cpan/Encode/t/Unicode.t @@ -1,5 +1,5 @@ # -# $Id: Unicode.t,v 2.1 2006/05/03 18:24:10 dankogai Exp $ +# $Id: Unicode.t,v 2.2 2009/11/16 14:08:13 dankogai Exp dankogai $ # # This script is written entirely in ASCII, even though quoted literals # do include non-BMP unicode characters -- Are you happy, jhi? @@ -20,8 +20,8 @@ BEGIN { use strict; #use Test::More 'no_plan'; -use Test::More tests => 37; -use Encode qw(encode decode); +use Test::More tests => 38; +use Encode qw(encode decode find_encoding); # # see @@ -131,5 +131,35 @@ for my $file (@file){ is(decode("UTF-7", encode("UTF-7", $content)), $content, "UTF-7 RT:$file"); } + +# Magic +{ + # see http://rt.perl.org/rt3//Ticket/Display.html?id=60472 + my $work = chr(0x100); + my $encoding = find_encoding("UTF16-BE"); + my $tied; + tie $tied, SomeScalar => \$work; + my $result = $encoding->encode($tied, 1); + is($work, "", "check set magic was applied"); +} + +package SomeScalar; +use Tie::Scalar; +use vars qw(@ISA); +BEGIN { @ISA = 'Tie::Scalar' } + +sub TIESCALAR { + my ($class, $ref) = @_; + return bless $ref, $class; +} + +sub FETCH { + ${$_[0]} +} + +sub STORE { + ${$_[0]} = $_[1]; +} + 1; __END__ diff --git a/cpan/Encode/t/piconv.t b/cpan/Encode/t/piconv.t index b24d753899..ee8a8149f8 100644 --- a/cpan/Encode/t/piconv.t +++ b/cpan/Encode/t/piconv.t @@ -1,20 +1,26 @@ # -# $Id: piconv.t,v 0.2 2009/07/13 00:50:52 dankogai Exp $ +# $Id: piconv.t,v 0.3 2009/11/16 14:08:13 dankogai Exp dankogai $ # +BEGIN { + if ( $ENV{'PERL_CORE'} && $] >= 5.011) { + print "1..0 # Skip: Don't know how to test this within perl's core\n"; + exit 0; + } +} + use strict; -use Config; use FindBin; use File::Spec; use IPC::Open3 qw(open3); use IO::Select; use Test::More; -my $nofork = ! $Config{d_fork}; +my $WIN = $^O eq 'MSWin32'; -if ($nofork) { +if ($WIN) { eval { require IPC::Run; IPC::Run->VERSION(0.83); 1; } or - plan skip_all => 'Without fork(), we require IPC::Run 0.83 to complete this test'; + plan skip_all => 'Win32 environments require IPC::Run 0.83 to complete this test'; } sub run_cmd (;$$); @@ -23,14 +29,14 @@ my $blib = File::Spec->rel2abs( File::Spec->catdir( $FindBin::RealBin, File::Spec->updir, 'blib' ) ); my $script = File::Spec->catdir($blib, 'script', 'piconv'); -my @base_cmd = ( $^X, ($ENV{PERL_CORE} ? () : "-Mblib=$blib"), $script ); +my @base_cmd = ( $^X, "-Mblib=$blib", $script ); plan tests => 5; { my ( $st, $out, $err ) = run_cmd; is( $st, 0, 'status for usage call' ); - is( $out, $nofork ? undef : '' ); + is( $out, $WIN ? undef : '' ); like( $err, qr{^piconv}, 'usage' ); } @@ -52,7 +58,7 @@ sub run_cmd (;$$) { my $err = "x" x 10_000; $err = ""; - if ($nofork) { + if ($WIN) { IPC::Run->import(qw(run timeout)); my @cmd; if (defined $args) { diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm index d3a5a4d507..15d4b3d19d 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm @@ -32,7 +32,8 @@ our $VERSION = '6.55_02'; $ENV{EMXSHELL} = 'sh'; # to run `commands` my $BORLAND = $Config{'cc'} =~ /^bcc/i ? 1 : 0; -my $GCC = $Config{'cc'} =~ /^gcc/i ? 1 : 0; +my $GCC = $Config{'cc'} =~ /\bgcc$/i ? 1 : 0; +my $DLLTOOL = $Config{'dlltool'} || 'dlltool'; =head2 Overridden methods @@ -309,9 +310,9 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP). '); if ($GCC) { push(@m, - q{ dlltool --def $(EXPORT_LIST) --output-exp dll.exp + q{ }.$DLLTOOL.q{ --def $(EXPORT_LIST) --output-exp dll.exp $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp - dlltool --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp + }.$DLLTOOL.q{ --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp }); } elsif ($BORLAND) { push(@m, diff --git a/cpan/File-Fetch/lib/File/Fetch.pm b/cpan/File-Fetch/lib/File/Fetch.pm index d093560126..d90232f413 100644 --- a/cpan/File-Fetch/lib/File/Fetch.pm +++ b/cpan/File-Fetch/lib/File/Fetch.pm @@ -22,7 +22,7 @@ use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT $FTP_PASSIVE $TIMEOUT $DEBUG $WARN ]; -$VERSION = '0.20'; +$VERSION = '0.22'; $VERSION = eval $VERSION; # avoid warnings with development releases $PREFER_BIN = 0; # XXX TODO implement $FROM_EMAIL = 'File-Fetch@example.com'; @@ -36,7 +36,7 @@ $WARN = 1; ### methods available to fetch the file depending on the scheme $METHODS = { - http => [ qw|lwp wget curl lftp lynx| ], + http => [ qw|lwp wget curl lftp lynx iosock| ], ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ], file => [ qw|lwp lftp file| ], rsync => [ qw|rsync| ] @@ -584,6 +584,86 @@ sub _lwp_fetch { } } +### Simple IO::Socket::INET fetching ### +sub _iosock_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + + my $use_list = { + 'IO::Socket::INET' => '0.0', + 'IO::Select' => '0.0', + }; + + if( can_load(modules => $use_list) ) { + my $sock = IO::Socket::INET->new( + PeerHost => $self->host, + ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ), + ); + + unless ( $sock ) { + return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!)); + } + + my $fh = FileHandle->new; + + # Check open() + + unless ( $fh->open($to,'>') ) { + return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + } + + my $path = File::Spec::Unix->catfile( $self->path, $self->file ); + my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a"; + $sock->send( $req ); + + my $select = IO::Select->new( $sock ); + + my $resp = ''; + my $normal = 0; + while ( $select->can_read( $TIMEOUT || 60 ) ) { + my $ret = $sock->sysread( $resp, 4096, length($resp) ); + if ( !defined $ret or $ret == 0 ) { + $select->remove( $sock ); + $normal++; + } + } + close $sock; + + unless ( $normal ) { + return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 ))); + } + + # Check the "response" + # Strip preceeding blank lines apparently they are allowed (RFC 2616 4.1) + $resp =~ s/^(\x0d?\x0a)+//; + # Check it is an HTTP response + unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) { + return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host)); + } + + # Check for OK + my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i; + unless ( $code eq '200' ) { + return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host)); + } + + print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0]; + close $fh; + return $to; + + } else { + $METHOD_FAIL->{'iosock'} = 1; + return; + } +} + ### Net::FTP fetching sub _netftp_fetch { my $self = shift; @@ -1186,7 +1266,7 @@ Below is a mapping of what utilities will be used in what order for what schemes, if available: file => LWP, lftp, file - http => LWP, wget, curl, lftp, lynx + http => LWP, wget, curl, lftp, lynx, iosock ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp rsync => rsync @@ -1198,6 +1278,9 @@ If a utility or module isn't available, it will be marked in a cache tried again. The C<fetch> method will only fail when all options are exhausted, and it was not able to retrieve the file. +C<iosock> is a very limited L<IO::Socket::INET> based mechanism for +retrieving C<http> schemed urls. It doesn't follow redirects for instance. + A special note about fetching files from an ftp uri: By default, all ftp connections are done in passive mode. To change @@ -1304,6 +1387,7 @@ the $BLACKLIST, $METHOD_FAIL and other internal functions. curl => curl rsync => rsync lftp => lftp + IO::Socket => iosock =head1 FREQUENTLY ASKED QUESTIONS diff --git a/cpan/File-Fetch/t/01_File-Fetch.t b/cpan/File-Fetch/t/01_File-Fetch.t index 1cd7e8d126..b057fcb13e 100644 --- a/cpan/File-Fetch/t/01_File-Fetch.t +++ b/cpan/File-Fetch/t/01_File-Fetch.t @@ -116,7 +116,9 @@ push @map, ( ### sanity tests -{ like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/, +{ + no warnings; + like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/, "User agent contains version" ); like( $File::Fetch::FROM_EMAIL, qr/@/, q[Email contains '@'] ); @@ -177,7 +179,7 @@ for my $entry (@map) { 'http://www.cpan.org/index.html?q=1', 'http://www.cpan.org/index.html?q=1&y=2', ) { - for (qw[lwp wget curl lftp lynx]) { + for (qw[lwp wget curl lftp lynx iosock]) { _fetch_uri( http => $uri, $_ ); } } diff --git a/cpan/File-Path/lib/File/Path.pm b/cpan/File-Path/lib/File/Path.pm index 387cdb19cb..5a9a88e402 100644 --- a/cpan/File-Path/lib/File/Path.pm +++ b/cpan/File-Path/lib/File/Path.pm @@ -17,7 +17,7 @@ BEGIN { use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = '2.08'; +$VERSION = '2.08_01'; @ISA = qw(Exporter); @EXPORT = qw(mkpath rmtree); @EXPORT_OK = qw(make_path remove_tree); @@ -279,7 +279,7 @@ sub _rmtree { my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; if ( -d _ ) { - $root = VMS::Filespec::pathify($root) if $Is_VMS; + $root = VMS::Filespec::vmspath(VMS::Filespec::pathify($root)) if $Is_VMS; if (!chdir($root)) { # see if we can escalate privileges to get in @@ -343,7 +343,6 @@ sub _rmtree { # filesystems is faster if done in reverse ASCIIbetical order. # include '.' to '.;' from blead patch #31775 @files = map {$_ eq '.' ? '.;' : $_} reverse @files; - ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//; } @files = grep {$_ ne $updir and $_ ne $curdir} @files; diff --git a/cpan/IO-Compress/Changes b/cpan/IO-Compress/Changes index 6460a72849..ef306447b6 100644 --- a/cpan/IO-Compress/Changes +++ b/cpan/IO-Compress/Changes @@ -1,8 +1,12 @@ CHANGES ------- - 2.021 30 August 2009 + 2.022 9 October 2009 + + * IO::Compress - Makefile.PL + Fix for core. + 2.021 30 August 2009 * IO::Compress::Base.pm - Less warnnings when reading from a closed filehandle. diff --git a/cpan/IO-Compress/Makefile.PL b/cpan/IO-Compress/Makefile.PL index 64cdd29dac..018e27bdc8 100644 --- a/cpan/IO-Compress/Makefile.PL +++ b/cpan/IO-Compress/Makefile.PL @@ -42,8 +42,8 @@ WriteMakefile( INSTALLDIRS => ($] >= 5.009 ? 'perl' : 'site'), ( - $] >= 5.009 && ! $ENV{PERL_CORE} - ? (INST_LIB => 'blib/arch') + $] >= 5.009 && $] <= 5.011001 && ! $ENV{PERL_CORE} + ? (INSTALLPRIVLIB => '$(INSTALLARCHLIB)') : () ), diff --git a/cpan/IO-Compress/README b/cpan/IO-Compress/README index 67cc0c6ed4..8da9fbfbaa 100644 --- a/cpan/IO-Compress/README +++ b/cpan/IO-Compress/README @@ -1,9 +1,9 @@ - IO-Compress + IO-Compress - Version 2.021 + Version 2.022 - 30th August 2009 + 9th October 2009 Copyright (c) 1995-2009 Paul Marquess. All rights reserved. This program is free software; you can redistribute it diff --git a/cpan/IO-Compress/lib/Compress/Zlib.pm b/cpan/IO-Compress/lib/Compress/Zlib.pm index 0a611039b8..604227c3a1 100644 --- a/cpan/IO-Compress/lib/Compress/Zlib.pm +++ b/cpan/IO-Compress/lib/Compress/Zlib.pm @@ -18,7 +18,7 @@ use warnings ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD); -$VERSION = '2.021'; +$VERSION = '2.022'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm index a56331d2cb..103a0452b6 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm @@ -10,7 +10,7 @@ use IO::Compress::Base::Common 2.021 qw(:Status); use Compress::Raw::Bzip2 2.021 ; our ($VERSION); -$VERSION = '2.021'; +$VERSION = '2.022'; sub mkCompObject { diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm index 525868093c..ac8f0364f9 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm @@ -9,7 +9,7 @@ use IO::Compress::Base::Common 2.021 qw(:Status); use Compress::Raw::Zlib 2.021 qw(Z_OK Z_FINISH MAX_WBITS) ; our ($VERSION); -$VERSION = '2.021'; +$VERSION = '2.022'; sub mkCompObject { diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm index c980e6c343..e83542fca7 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm @@ -7,7 +7,7 @@ use bytes; use IO::Compress::Base::Common 2.021 qw(:Status); our ($VERSION); -$VERSION = '2.021'; +$VERSION = '2.022'; sub mkCompObject { diff --git a/cpan/IO-Compress/lib/IO/Compress/Base.pm b/cpan/IO-Compress/lib/IO/Compress/Base.pm index 7b558eafeb..bdd8d79513 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Base.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Base.pm @@ -20,7 +20,7 @@ use bytes; our (@ISA, $VERSION); @ISA = qw(Exporter IO::File); -$VERSION = '2.021'; +$VERSION = '2.022'; #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. diff --git a/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm b/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm index 7981585d49..26af4f87b0 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm @@ -11,7 +11,7 @@ use File::GlobMapper; require Exporter; our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); @ISA = qw(Exporter); -$VERSION = '2.021'; +$VERSION = '2.022'; @EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput isaFileGlobString cleanFileGlobString oneTarget @@ -589,7 +589,7 @@ sub IO::Compress::Base::Parameters::parse $key = lc $key; if ($firstTime || ! $sticky) { - $x = [ $x ] + $x = [] if $type & Parse_multiple; $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ; diff --git a/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm b/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm index e5f86b2f36..28725c64a8 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm @@ -14,7 +14,7 @@ use IO::Compress::Adapter::Bzip2 2.021 ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error); -$VERSION = '2.021'; +$VERSION = '2.022'; $Bzip2Error = ''; @ISA = qw(Exporter IO::Compress::Base); diff --git a/cpan/IO-Compress/lib/IO/Compress/Deflate.pm b/cpan/IO-Compress/lib/IO/Compress/Deflate.pm index 7ee0a53997..2e1a19fe07 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Deflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Deflate.pm @@ -15,7 +15,7 @@ use IO::Compress::Base::Common 2.021 qw(createSelfTiedObject); our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError); -$VERSION = '2.021'; +$VERSION = '2.022'; $DeflateError = ''; @ISA = qw(Exporter IO::Compress::RawDeflate); diff --git a/cpan/IO-Compress/lib/IO/Compress/Gzip.pm b/cpan/IO-Compress/lib/IO/Compress/Gzip.pm index 5ddfad20b9..f2e60f6557 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Gzip.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Gzip.pm @@ -27,7 +27,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError); -$VERSION = '2.021'; +$VERSION = '2.022'; $GzipError = '' ; @ISA = qw(Exporter IO::Compress::RawDeflate); diff --git a/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm index 826183680e..095668e4fb 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); -$VERSION = '2.021'; +$VERSION = '2.022'; @ISA = qw(Exporter); diff --git a/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm b/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm index ad642dbfa5..02a8cda27a 100644 --- a/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm @@ -16,7 +16,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); -$VERSION = '2.021'; +$VERSION = '2.022'; $RawDeflateError = ''; @ISA = qw(Exporter IO::Compress::Base); diff --git a/cpan/IO-Compress/lib/IO/Compress/Zip.pm b/cpan/IO-Compress/lib/IO/Compress/Zip.pm index 563b10d9bf..d6e6167b95 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zip.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zip.pm @@ -32,7 +32,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError); -$VERSION = '2.021'; +$VERSION = '2.022'; $ZipError = ''; @ISA = qw(Exporter IO::Compress::RawDeflate); diff --git a/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm index d16eb238ef..a554d49df6 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm @@ -7,7 +7,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS); -$VERSION = '2.021'; +$VERSION = '2.022'; @ISA = qw(Exporter); diff --git a/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm index d65fedc580..6b935ffc11 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT); -$VERSION = '2.021'; +$VERSION = '2.022'; @ISA = qw(Exporter); diff --git a/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm b/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm index 72b4ddd370..0c88017a63 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm @@ -8,7 +8,7 @@ use bytes; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = '2.021'; +$VERSION = '2.022'; use IO::Compress::Gzip::Constants 2.021 ; diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm index b2053aff10..796aadb416 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm @@ -9,7 +9,7 @@ use IO::Compress::Base::Common 2.021 qw(:Status); use Compress::Raw::Bzip2 2.021 ; our ($VERSION, @ISA); -$VERSION = '2.021'; +$VERSION = '2.022'; sub mkUncompObject { diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm index 0df174320a..834eb5d230 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm @@ -8,7 +8,7 @@ use IO::Compress::Base::Common 2.021 qw(:Status); our ($VERSION); -$VERSION = '2.021'; +$VERSION = '2.022'; use Compress::Raw::Zlib 2.021 (); diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm index d03148c0b4..5c67c1b6a8 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm @@ -8,7 +8,7 @@ use IO::Compress::Base::Common 2.021 qw(:Status); use Compress::Raw::Zlib 2.021 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); our ($VERSION); -$VERSION = '2.021'; +$VERSION = '2.022'; diff --git a/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm index e8ffc5c15b..900feda477 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm @@ -21,7 +21,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); -$VERSION = '2.021'; +$VERSION = '2.022'; $AnyInflateError = ''; @ISA = qw( Exporter IO::Uncompress::Base ); diff --git a/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm b/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm index cc1ba24b47..c4406e55d5 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm @@ -13,7 +13,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError); -$VERSION = '2.021'; +$VERSION = '2.022'; $AnyUncompressError = ''; @ISA = qw( Exporter IO::Uncompress::Base ); @@ -31,8 +31,8 @@ BEGIN eval ' use IO::Uncompress::Adapter::Bunzip2 2.021 ;'; eval ' use IO::Uncompress::Adapter::LZO 2.021 ;'; eval ' use IO::Uncompress::Adapter::Lzf 2.021 ;'; - eval ' use IO::Uncompress::Adapter::UnLzma 2.020 ;'; - eval ' use IO::Uncompress::Adapter::UnXz 2.020 ;'; + #eval ' use IO::Uncompress::Adapter::UnLzma 2.020 ;'; + #eval ' use IO::Uncompress::Adapter::UnXz 2.020 ;'; eval ' use IO::Uncompress::Bunzip2 2.021 ;'; eval ' use IO::Uncompress::UnLzop 2.021 ;'; @@ -41,8 +41,8 @@ BEGIN eval ' use IO::Uncompress::RawInflate 2.021 ;'; eval ' use IO::Uncompress::Unzip 2.021 ;'; eval ' use IO::Uncompress::UnLzf 2.021 ;'; - eval ' use IO::Uncompress::UnLzma 2.018 ;'; - eval ' use IO::Uncompress::UnXz 2.018 ;'; + #eval ' use IO::Uncompress::UnLzma 2.018 ;'; + #eval ' use IO::Uncompress::UnXz 2.018 ;'; } sub new @@ -61,7 +61,8 @@ sub anyuncompress sub getExtraParams { use IO::Compress::Base::Common 2.021 qw(:Parse); - return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ) ; + return ( 'RawInflate' => [1, 1, Parse_boolean, 0] , + 'UnLzma' => [1, 1, Parse_boolean, 0] ) ; } sub ckParams @@ -107,7 +108,7 @@ sub mkUncomp } } -# if (defined $IO::Uncompress::UnLzma::VERSION ) +# if (defined $IO::Uncompress::UnLzma::VERSION && $got->value('UnLzma')) # { # my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnLzma::mkUncompObject(); # @@ -125,21 +126,21 @@ sub mkUncomp # return 1; # } # } - - if (defined $IO::Uncompress::UnXz::VERSION and - $magic = $self->ckMagic('UnXz')) { - *$self->{Info} = $self->readHeader($magic) - or return undef ; - - my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnXz::mkUncompObject(); - - return $self->saveErrorString(undef, $errstr, $errno) - if ! defined $obj; - - *$self->{Uncomp} = $obj; - - return 1; - } +# +# if (defined $IO::Uncompress::UnXz::VERSION and +# $magic = $self->ckMagic('UnXz')) { +# *$self->{Info} = $self->readHeader($magic) +# or return undef ; +# +# my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnXz::mkUncompObject(); +# +# return $self->saveErrorString(undef, $errstr, $errno) +# if ! defined $obj; +# +# *$self->{Uncomp} = $obj; +# +# return 1; +# } if (defined $IO::Uncompress::Bunzip2::VERSION and $magic = $self->ckMagic('Bunzip2')) { diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Base.pm b/cpan/IO-Compress/lib/IO/Uncompress/Base.pm index 8459ce0e05..eccff87b2c 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Base.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Base.pm @@ -9,7 +9,7 @@ our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(Exporter IO::File); -$VERSION = '2.021'; +$VERSION = '2.022'; use constant G_EOF => 0 ; use constant G_ERR => -1 ; diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm b/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm index ce483ea738..22cf65d450 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm @@ -12,7 +12,7 @@ use IO::Uncompress::Adapter::Bunzip2 2.021 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error); -$VERSION = '2.021'; +$VERSION = '2.022'; $Bunzip2Error = ''; @ISA = qw( Exporter IO::Uncompress::Base ); diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm b/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm index 8922865d43..41b6d3d4f6 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm @@ -28,7 +28,7 @@ Exporter::export_ok_tags('all'); $GunzipError = ''; -$VERSION = '2.021'; +$VERSION = '2.022'; sub new { diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm index 20aecc7864..1a22263626 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm @@ -13,7 +13,7 @@ use IO::Uncompress::RawInflate 2.021 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); -$VERSION = '2.021'; +$VERSION = '2.022'; $InflateError = ''; @ISA = qw( Exporter IO::Uncompress::RawInflate ); diff --git a/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm index 5727192e7c..3a45fcdde8 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm @@ -14,7 +14,7 @@ use IO::Uncompress::Adapter::Inflate 2.021 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); -$VERSION = '2.021'; +$VERSION = '2.022'; $RawInflateError = ''; @ISA = qw( Exporter IO::Uncompress::Base ); diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm b/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm index 7d08c84edc..c9f638ad2e 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm @@ -30,7 +30,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup); -$VERSION = '2.021'; +$VERSION = '2.022'; $UnzipError = ''; @ISA = qw(Exporter IO::Uncompress::RawInflate); diff --git a/cpan/IO-Compress/t/01misc.t b/cpan/IO-Compress/t/01misc.t index a7a31fbe15..85cfd37902 100644 --- a/cpan/IO-Compress/t/01misc.t +++ b/cpan/IO-Compress/t/01misc.t @@ -86,11 +86,14 @@ sub My::testParseParameters() like $@, mkErr("Parameter 'Fred' not a scalar"), "wanted scalar"; - #eval { ParseParameters(1, {'Fred' => [1, 1, Parse_any|Parse_multiple, 0]}, Fred => 1, Fred => 2) ; }; - #like $@, mkErr("Muliple instances of 'Fred' found"), - #"wanted scalar"; +# eval { ParseParameters(1, {'Fred' => [1, 1, Parse_any, 0]}, Fred => 1, Fred => 2) ; }; +# like $@, mkErr("Muliple instances of 'Fred' found"), +# "wanted scalar"; - ok 1; + my $g = ParseParameters(1, {'Fred' => [1, 1, Parse_unsigned|Parse_multiple, 7]}, Fred => 1, Fred => 2) ; + is_deeply $g->value('Fred'), [ 1, 2 ] ; + + #ok 1; my $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ; is $got->value('Fred'), "abc", "other" ; diff --git a/cpan/IO-Compress/t/compress/CompTestUtils.pm b/cpan/IO-Compress/t/compress/CompTestUtils.pm index cb63d6274c..c5452b6b13 100644 --- a/cpan/IO-Compress/t/compress/CompTestUtils.pm +++ b/cpan/IO-Compress/t/compress/CompTestUtils.pm @@ -16,7 +16,7 @@ use Carp ; sub title { #diag "" ; - ok 1, $_[0] ; + ok(1, $_[0]) ; #diag "" ; } @@ -476,6 +476,7 @@ sub anyUncompress Append => 1, Transparent => 0, RawInflate => 1, + #UnLzma => 1, @opts or croak "Cannot open buffer/file: $AnyUncompressError" ; @@ -537,6 +538,7 @@ sub getHeaders Append => 1, Transparent => 0, RawInflate => 1, + #UnLzma => 1, @opts or croak "Cannot open buffer/file: $AnyUncompressError" ; @@ -647,7 +649,7 @@ sub getMultiValues { my $class = shift ; - return (0,0) if $class =~ /lzf/i; + return (0,0) if $class =~ /lzf|lzma/i; return (1,0); } diff --git a/cpan/IO-Compress/t/compress/any.pl b/cpan/IO-Compress/t/compress/any.pl index d95766b0a9..23a23295aa 100644 --- a/cpan/IO-Compress/t/compress/any.pl +++ b/cpan/IO-Compress/t/compress/any.pl @@ -57,6 +57,7 @@ sub run { my $unc = new $AnyConstruct $input, Transparent => $trans, RawInflate => 1, + #UnLzma => 1, Append => 1 ; ok $unc, " Created $AnyClass object" @@ -76,6 +77,7 @@ sub run { my $unc = new $AnyConstruct $input, Transparent => $trans, RawInflate => 1, + #UnLzma => 1, Append => 1 ; ok $unc, " Created $AnyClass object" diff --git a/cpan/IO-Compress/t/compress/oneshot.pl b/cpan/IO-Compress/t/compress/oneshot.pl index 9c76cefdb5..78d17275b7 100644 --- a/cpan/IO-Compress/t/compress/oneshot.pl +++ b/cpan/IO-Compress/t/compress/oneshot.pl @@ -276,7 +276,7 @@ sub run my $FuncInverse = getTopFuncRef($TopTypeInverse); my @opts = (); - @opts = (RawInflate => 1) + @opts = (RawInflate => 1, UnLzma => 1) if $CompressClass eq 'IO::Compress::RawInflate'; for my $append ( 1, 0 ) @@ -615,7 +615,7 @@ sub run { title "Truncated file"; skip '', 7 - if $CompressClass =~ /lzop|lzf/i ; + if $CompressClass =~ /lzop|lzf|lzma/i ; my @in ; push @in, "abcde" x 10; @@ -1020,7 +1020,7 @@ sub run my $incumbent = "incumbent data" ; my @opts = (Strict => 1); - push @opts, (RawInflate => 1) + push @opts, (RawInflate => 1, UnLzma => 1) if $bit eq 'IO::Uncompress::AnyUncompress'; for my $append (0, 1) @@ -1321,7 +1321,7 @@ sub run my $keep_comp = $comp; my @opts = (); - @opts = (RawInflate => 1) + @opts = (RawInflate => 1, UnLzma => 1) if $bit eq 'IO::Uncompress::AnyUncompress'; my $incumbent = "incumbent data" ; @@ -1407,7 +1407,7 @@ sub run mkdir $tmpDir2, 0777; my @opts = (); - @opts = (RawInflate => 1) + @opts = (RawInflate => 1, UnLzma => 1) if $bit eq 'IO::Uncompress::AnyUncompress'; ok -d $tmpDir1, " Temp Directory $tmpDir1 exists"; diff --git a/cpan/IO-Compress/t/compress/truncate.pl b/cpan/IO-Compress/t/compress/truncate.pl index b362fd3b6e..063355b519 100644 --- a/cpan/IO-Compress/t/compress/truncate.pl +++ b/cpan/IO-Compress/t/compress/truncate.pl @@ -64,7 +64,7 @@ sub run ok $gz; ok ! $gz->error() ; my $buff ; - is $gz->read($buff), length($part) ; + is $gz->read($buff, 5000), length($part) ; ok $buff eq $part ; ok $gz->eof() ; $gz->close(); diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm index 81d85ca39a..e60c93fda2 100644 --- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm +++ b/cpan/IPC-Cmd/lib/IPC/Cmd.pm @@ -13,18 +13,30 @@ BEGIN { use Exporter (); use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG - $USE_IPC_RUN $USE_IPC_OPEN3 $WARN + $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN ]; - $VERSION = '0.50'; + $VERSION = '0.54'; $VERBOSE = 0; $DEBUG = 0; $WARN = 1; $USE_IPC_RUN = IS_WIN32 && !IS_WIN98; $USE_IPC_OPEN3 = not IS_VMS; + $CAN_USE_RUN_FORKED = 0; + eval { + require POSIX; POSIX->import(); + require IPC::Open3; IPC::Open3->import(); + require IO::Select; IO::Select->import(); + require IO::Handle; IO::Handle->import(); + require FileHandle; FileHandle->import(); + require Socket; Socket->import(); + require Time::HiRes; Time::HiRes->import(); + }; + $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32; + @ISA = qw[Exporter]; - @EXPORT_OK = qw[can_run run QUOTE]; + @EXPORT_OK = qw[can_run run run_forked QUOTE]; } require Carp; @@ -42,7 +54,7 @@ IPC::Cmd - finding and running system commands made easy =head1 SYNOPSIS - use IPC::Cmd qw[can_run run]; + use IPC::Cmd qw[can_run run run_forked]; my $full_path = can_run('wget') or warn 'wget is not installed!'; @@ -160,6 +172,10 @@ sub can_capture_buffer { return; } +=head2 $bool = IPC::Cmd->can_use_run_forked + +Utility function that tells you if C<IPC::Cmd> is capable of +providing C<run_forked> on the current platform. =head1 FUNCTIONS @@ -320,6 +336,495 @@ what modules or function calls to use when issuing a command. } } +sub can_use_run_forked { + return $CAN_USE_RUN_FORKED eq "1"; +} + +# give process a chance sending TERM, +# waiting for a while (2 seconds) +# and killing it with KILL +sub kill_gently { + my ($pid) = @_; + + kill(15, $pid); + + my $wait_cycles = 0; + my $child_finished = 0; + + while (!$child_finished && $wait_cycles < 8) { + my $waitpid = waitpid($pid, WNOHANG); + if ($waitpid eq -1) { + $child_finished = 1; + } + + $wait_cycles = $wait_cycles + 1; + Time::HiRes::usleep(250000); # half a second + } +} + +sub open3_run { + my ($cmd, $opts) = @_; + + $opts = {} unless $opts; + + my $child_in = FileHandle->new; + my $child_out = FileHandle->new; + my $child_err = FileHandle->new; + $child_out->autoflush(1); + $child_err->autoflush(1); + + my $pid = open3($child_in, $child_out, $child_err, $cmd); + + # push my child's pid to our parent + # so in case i am killed parent + # could stop my child (search for + # child_child_pid in parent code) + if ($opts->{'parent_info'}) { + my $ps = $opts->{'parent_info'}; + print $ps "spawned $pid\n"; + } + + if ($child_in && $child_out->opened && $opts->{'child_stdin'}) { + + # If the child process dies for any reason, + # the next write to CHLD_IN is likely to generate + # a SIGPIPE in the parent, which is fatal by default. + # So you may wish to handle this signal. + # + # from http://perldoc.perl.org/IPC/Open3.html, + # absolutely needed to catch piped commands errors. + # + local $SIG{'SIG_PIPE'} = sub { 1; }; + + print $child_in $opts->{'child_stdin'}; + } + close($child_in); + + my $child_output = { + 'out' => $child_out->fileno, + 'err' => $child_err->fileno, + $child_out->fileno => { + 'parent_socket' => $opts->{'parent_stdout'}, + 'scalar_buffer' => "", + 'child_handle' => $child_out, + 'block_size' => ($child_out->stat)[11] || 1024, + }, + $child_err->fileno => { + 'parent_socket' => $opts->{'parent_stderr'}, + 'scalar_buffer' => "", + 'child_handle' => $child_err, + 'block_size' => ($child_err->stat)[11] || 1024, + }, + }; + + my $select = IO::Select->new(); + $select->add($child_out, $child_err); + + # pass any signal to the child + # effectively creating process + # strongly attached to the child: + # it will terminate only after child + # has terminated (except for SIGKILL, + # which is specially handled) + foreach my $s (keys %SIG) { + my $sig_handler; + $sig_handler = sub { + kill("$s", $pid); + $SIG{$s} = $sig_handler; + }; + $SIG{$s} = $sig_handler; + } + + my $child_finished = 0; + + my $got_sig_child = 0; + $SIG{'CHLD'} = sub { $got_sig_child = time(); }; + + while(!$child_finished && ($child_out->opened || $child_err->opened)) { + + # parent was killed otherwise we would have got + # the same signal as parent and process it same way + if (getppid() eq "1") { + kill_gently($pid); + exit; + } + + if ($got_sig_child) { + if (time() - $got_sig_child > 10) { + print STDERR "select->can_read did not return 0 for 10 seconds after SIG_CHLD, killing [$pid]\n"; + kill (-9, $pid); + $child_finished = 1; + } + } + + Time::HiRes::usleep(1); + + foreach my $fd ($select->can_read(1/100)) { + my $str = $child_output->{$fd->fileno}; + psSnake::die("child stream not found: $fd") unless $str; + + my $data; + my $count = $fd->sysread($data, $str->{'block_size'}); + + if ($count) { + if ($str->{'parent_socket'}) { + my $ph = $str->{'parent_socket'}; + print $ph $data; + } + else { + $str->{'scalar_buffer'} .= $data; + } + } + elsif ($count eq 0) { + $select->remove($fd); + $fd->close(); + } + else { + psSnake::die("error during sysread: " . $!); + } + } + } + + waitpid($pid, 0); + + # i've successfully reaped my child, + # let my parent know this + if ($opts->{'parent_info'}) { + my $ps = $opts->{'parent_info'}; + print $ps "reaped $pid\n"; + } + + my $real_exit = $?; + my $exit_value = $real_exit >> 8; + if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) { + return $exit_value; + } + else { + return { + 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'}, + 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'}, + 'exit_code' => $exit_value, + }; + } +} + +=head2 $hashref = run_forked( command => COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} ); + +C<run_forked> is used to execute some program, +optionally feed it with some input, get its return code +and output (both stdout and stderr into seperate buffers). +In addition it allows to terminate the program +which take too long to finish. + +The important and distinguishing feature of run_forked +is execution timeout which at first seems to be +quite a simple task but if you think +that the program which you're spawning +might spawn some children itself (which +in their turn could do the same and so on) +it turns out to be not a simple issue. + +C<run_forked> is designed to survive and +successfully terminate almost any long running task, +even a fork bomb in case your system has the resources +to survive during given timeout. + +This is achieved by creating separate watchdog process +which spawns the specified program in a separate +process session and supervises it: optionally +feeds it with input, stores its exit code, +stdout and stderr, terminates it in case +it runs longer than specified. + +Invocation requires the command to be executed and optionally a hashref of options: + +=over + +=item C<timeout> + +Specify in seconds how long the command may run for before it is killed with with SIG_KILL (9) +which effectively terminates it and all of its children (direct or indirect). + +=item C<child_stdin> + +Specify some text that will be passed into C<STDIN> of the executed program. + +=item C<stdout_handler> + +You may provide a coderef of a subroutine that will be called a portion of data is received on +stdout from the executing program. + +=item C<stderr_handler> + +You may provide a coderef of a subroutine that will be called a portion of data is received on +stderr from the executing program. + +=back + +C<run_forked> will return a HASHREF with the following keys: + +=over + +=item C<exit_code> + +The exit code of the executed program. + +=item C<timeout> + +The number of seconds the program ran for before being terminated, or 0 if no timeout occurred. + +=item C<stdout> + +Holds the standard output of the executed command +(or empty string if there were no stdout output; it's always defined!) + +=item C<stderr> + +Holds the standard error of the executed command +(or empty string if there were no stderr output; it's always defined!) + +=item C<merged> + +Holds the standard output and error of the executed command merged into one stream +(or empty string if there were no output at all; it's always defined!) + +=item C<err_msg> + +Holds some explanation in the case of an error. + +=back + +=cut + +sub run_forked { + ### container to store things in + my $self = bless {}, __PACKAGE__; + + if (!can_use_run_forked()) { + Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED"); + return; + } + + my ($cmd, $opts) = @_; + + if (!$cmd) { + Carp::carp("run_forked expects command to run"); + return; + } + + $opts = {} unless $opts; + $opts->{'timeout'} = 0 unless $opts->{'timeout'}; + + # sockets to pass child stdout to parent + my $child_stdout_socket; + my $parent_stdout_socket; + + # sockets to pass child stderr to parent + my $child_stderr_socket; + my $parent_stderr_socket; + + # sockets for child -> parent internal communication + my $child_info_socket; + my $parent_info_socket; + + socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || + die ("socketpair: $!"); + socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || + die ("socketpair: $!"); + socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || + die ("socketpair: $!"); + + $child_stdout_socket->autoflush(1); + $parent_stdout_socket->autoflush(1); + $child_stderr_socket->autoflush(1); + $parent_stderr_socket->autoflush(1); + $child_info_socket->autoflush(1); + $parent_info_socket->autoflush(1); + + my $start_time = time(); + + my $pid; + if ($pid = fork) { + + # we are a parent + close($parent_stdout_socket); + close($parent_stderr_socket); + close($parent_info_socket); + + my $child_timedout = 0; + my $flags; + + # prepare sockets to read from child + + $flags = 0; + fcntl($child_stdout_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + $flags |= O_NONBLOCK; + fcntl($child_stdout_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + + $flags = 0; + fcntl($child_stderr_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + $flags |= O_NONBLOCK; + fcntl($child_stderr_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + + $flags = 0; + fcntl($child_info_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + $flags |= O_NONBLOCK; + fcntl($child_info_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + + # print "child $pid started\n"; + + my $child_finished = 0; + my $child_stdout = ''; + my $child_stderr = ''; + my $child_merged = ''; + my $child_exit_code = 0; + + my $got_sig_child = 0; + $SIG{'CHLD'} = sub { $got_sig_child = time(); }; + + my $child_child_pid; + + while (!$child_finished) { + # user specified timeout + if ($opts->{'timeout'}) { + if (time() - $start_time > $opts->{'timeout'}) { + kill (-9, $pid); + $child_timedout = 1; + } + } + + # give OS 10 seconds for correct return of waitpid, + # kill process after that and finish wait loop; + # shouldn't ever happen -- remove this code? + if ($got_sig_child) { + if (time() - $got_sig_child > 10) { + print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n"; + kill (-9, $pid); + $child_finished = 1; + } + } + + my $waitpid = waitpid($pid, WNOHANG); + + # child finished, catch it's exit status + if ($waitpid ne 0 && $waitpid ne -1) { + $child_exit_code = $? >> 8; + } + + if ($waitpid eq -1) { + $child_finished = 1; + next; + } + + # child -> parent simple internal communication protocol + while (my $l = <$child_info_socket>) { + if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) { + $child_child_pid = $1; + $l = $2; + } + if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) { + $child_child_pid = undef; + $l = $2; + } + } + + while (my $l = <$child_stdout_socket>) { + $child_stdout .= $l; + $child_merged .= $l; + + if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') { + $opts->{'stdout_handler'}->($l); + } + } + while (my $l = <$child_stderr_socket>) { + $child_stderr .= $l; + $child_merged .= $l; + + if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') { + $opts->{'stderr_handler'}->($l); + } + } + + Time::HiRes::usleep(1); + } + + # $child_pid_pid is not defined in two cases: + # * when our child was killed before + # it had chance to tell us the pid + # of the child it spawned. we can do + # nothing in this case :( + # * our child successfully reaped its child, + # we have nothing left to do in this case + # + # defined $child_pid_pid means child's child + # has not died but nobody is waiting for it, + # killing it brutaly. + # + if ($child_child_pid) { + kill_gently($child_child_pid); + } + + # print "child $pid finished\n"; + + close($child_stdout_socket); + close($child_stderr_socket); + close($child_info_socket); + + my $o = { + 'stdout' => $child_stdout, + 'stderr' => $child_stderr, + 'merged' => $child_merged, + 'timeout' => $child_timedout ? $opts->{'timeout'} : 0, + 'exit_code' => $child_exit_code, + }; + + my $err_msg = ''; + if ($o->{'exit_code'}) { + $err_msg .= "exited with code [$o->{'exit_code'}]\n"; + } + if ($o->{'timeout'}) { + $err_msg .= "ran more than [$o->{'timeout'}] seconds\n"; + } + if ($o->{'stdout'}) { + $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n"; + } + if ($o->{'stderr'}) { + $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n"; + } + $o->{'err_msg'} = $err_msg; + + return $o; + } + else { + die("cannot fork: $!") unless defined($pid); + + # create new process session for open3 call, + # so we hopefully can kill all the subprocesses + # which might be spawned in it (except for those + # which do setsid theirselves -- can't do anything + # with those) + + POSIX::setsid() || die("Error running setsid: " . $!); + + close($child_stdout_socket); + close($child_stderr_socket); + close($child_info_socket); + + my $child_exit_code = open3_run($cmd, { + 'parent_info' => $parent_info_socket, + 'parent_stdout' => $parent_stdout_socket, + 'parent_stderr' => $parent_stderr_socket, + 'child_stdin' => $opts->{'child_stdin'}, + }); + + close($parent_stdout_socket); + close($parent_stderr_socket); + close($parent_info_socket); + + exit $child_exit_code; + } +} + sub run { ### container to store things in my $self = bless {}, __PACKAGE__; @@ -1123,6 +1628,8 @@ C<IPC::Run>, C<IPC::Open3> Thanks to James Mastros and Martijn van der Streek for their help in getting IPC::Open3 to behave nicely. +Thanks to Petya Kohts for the C<run_forked> code. + =head1 BUG REPORTS Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>. diff --git a/cpan/IPC-Cmd/t/01_IPC-Cmd.t b/cpan/IPC-Cmd/t/01_IPC-Cmd.t index eca515ec0c..0773479ad4 100644 --- a/cpan/IPC-Cmd/t/01_IPC-Cmd.t +++ b/cpan/IPC-Cmd/t/01_IPC-Cmd.t @@ -9,8 +9,8 @@ use Test::More 'no_plan'; my $Class = 'IPC::Cmd'; my $AClass = $Class . '::TimeOut'; -my @Funcs = qw[run can_run QUOTE]; -my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer]; +my @Funcs = qw[run can_run QUOTE run_forked]; +my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer can_use_run_forked]; my $IsWin32 = $^O eq 'MSWin32'; my $Verbose = @ARGV ? 1 : 0; @@ -155,6 +155,23 @@ push @Prefs, [ 0, 0 ], [ 0, 0 ]; } } } + +unless ( IPC::Cmd->can_use_run_forked ) { + ok(1, "run_forked not available on this platform"); + exit; +} + +{ + my $cmd = "echo out ; echo err >&2 ; sleep 4"; + my $r = run_forked($cmd, {'timeout' => 1}); + + ok(ref($r) eq 'HASH', "executed: $cmd"); + ok($r->{'timeout'} eq 1, "timed out"); + ok($r->{'stdout'}, "stdout: " . $r->{'stdout'}); + ok($r->{'stderr'}, "stderr: " . $r->{'stderr'}); +} + + __END__ ### special call to check that output is interleaved properly { my $cmd = [$^X, File::Spec->catfile( qw[src output.pl] ) ]; @@ -219,6 +236,4 @@ __END__ like( $err,qr/^$AClass/," Error '$err' mentions $AClass" ); } } - - diff --git a/cpan/List-Util/Changes b/cpan/List-Util/Changes index 737b94dd68..8f71596e13 100644 --- a/cpan/List-Util/Changes +++ b/cpan/List-Util/Changes @@ -1,3 +1,11 @@ +1.22 -- Sat Nov 14 09:26:15 CST 2009 + + * silence a compiler warning about an unreferenced local variable [Steve Hay] + * RT#51484 Preserve utf8 flag of string passed to dualvar() + * RT#51454 Check first argument to first/reduce is a code reference + * RT#50528 [PATCH] p_tainted.t fix for VMS [Craig A. Berry] + * RT#48550 fix pure perl looks_like_number not to match non-ascii digits + 1.21 -- Mon May 18 10:32:14 CDT 2009 * Change build system for perl-only install not to need to modify blib diff --git a/cpan/List-Util/ListUtil.xs b/cpan/List-Util/ListUtil.xs index c2f69a6b56..dfde039fb6 100644 --- a/cpan/List-Util/ListUtil.xs +++ b/cpan/List-Util/ListUtil.xs @@ -194,7 +194,6 @@ CODE: SV *sv; SV *retsv = NULL; int index; - int magic; NV retval = 0; if(!items) { XSRETURN_UNDEF; @@ -334,6 +333,9 @@ CODE: XSRETURN_UNDEF; } cv = sv_2cv(block, &stash, &gv, 0); + if (cv == Nullcv) { + croak("Not a subroutine reference"); + } PUSH_MULTICALL(cv); SAVESPTR(GvSV(PL_defgv)); @@ -406,6 +408,8 @@ CODE: ST(0) = sv_newmortal(); (void)SvUPGRADE(ST(0),SVt_PVNV); sv_setpvn(ST(0),ptr,len); + if (SvUTF8(str)) + SvUTF8_on(ST(0)); if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { SvNV_set(ST(0), SvNV(num)); SvNOK_on(ST(0)); diff --git a/cpan/List-Util/lib/List/Util.pm b/cpan/List-Util/lib/List/Util.pm index 426a7a3b8d..2b51a69d79 100644 --- a/cpan/List-Util/lib/List/Util.pm +++ b/cpan/List-Util/lib/List/Util.pm @@ -14,7 +14,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.21"; +$VERSION = "1.22"; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/cpan/List-Util/lib/List/Util/PP.pm b/cpan/List-Util/lib/List/Util/PP.pm index 7fa2a55a21..425f1c5015 100644 --- a/cpan/List-Util/lib/List/Util/PP.pm +++ b/cpan/List-Util/lib/List/Util/PP.pm @@ -13,12 +13,14 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.21"; +$VERSION = "1.22"; $VERSION = eval $VERSION; sub reduce (&@) { my $code = shift; - unless(ref($code)) { + require Scalar::Util; + my $type = Scalar::Util::reftype($code); + unless($type and $type eq 'CODE') { require Carp; Carp::croak("Not a subroutine reference"); } @@ -43,6 +45,12 @@ sub reduce (&@) { sub first (&@) { my $code = shift; + require Scalar::Util; + my $type = Scalar::Util::reftype($code); + unless($type and $type eq 'CODE') { + require Carp; + Carp::croak("Not a subroutine reference"); + } foreach (@_) { return $_ if &{$code}(); diff --git a/cpan/List-Util/lib/List/Util/XS.pm b/cpan/List-Util/lib/List/Util/XS.pm index 01ad27ac12..76bf6469c4 100644 --- a/cpan/List-Util/lib/List/Util/XS.pm +++ b/cpan/List-Util/lib/List/Util/XS.pm @@ -3,7 +3,7 @@ use strict; use vars qw($VERSION); use List::Util; -$VERSION = "1.21"; # FIXUP +$VERSION = "1.22"; # FIXUP $VERSION = eval $VERSION; # FIXUP sub _VERSION { # FIXUP diff --git a/cpan/List-Util/lib/Scalar/Util.pm b/cpan/List-Util/lib/Scalar/Util.pm index db7b20c5c6..24f146f2b3 100644 --- a/cpan/List-Util/lib/Scalar/Util.pm +++ b/cpan/List-Util/lib/Scalar/Util.pm @@ -13,7 +13,7 @@ require List::Util; # List::Util loads the XS @ISA = qw(Exporter); @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); -$VERSION = "1.21"; +$VERSION = "1.22"; $VERSION = eval $VERSION; unless (defined &dualvar) { diff --git a/cpan/List-Util/lib/Scalar/Util/PP.pm b/cpan/List-Util/lib/Scalar/Util/PP.pm index 0b7f7994ba..e94fe86f21 100644 --- a/cpan/List-Util/lib/Scalar/Util/PP.pm +++ b/cpan/List-Util/lib/Scalar/Util/PP.pm @@ -16,7 +16,7 @@ use B qw(svref_2object); @ISA = qw(Exporter); @EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number); -$VERSION = "1.21"; +$VERSION = "1.22"; $VERSION = eval $VERSION; sub blessed ($) { @@ -98,8 +98,8 @@ sub looks_like_number { require overload; return overload::Overloaded($_) ? defined(0 + $_) : 0; } - return 1 if (/^[+-]?\d+$/); # is a +/- integer - return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float + return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer + return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); 0; diff --git a/cpan/List-Util/t/dualvar.t b/cpan/List-Util/t/dualvar.t index fab3691a32..5c0fe2140b 100644 --- a/cpan/List-Util/t/dualvar.t +++ b/cpan/List-Util/t/dualvar.t @@ -16,7 +16,7 @@ BEGIN { use Scalar::Util (); use Test::More (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) ? (skip_all => 'dualvar requires XS version') - : (tests => 11); + : (tests => 13); Scalar::Util->import('dualvar'); @@ -49,13 +49,22 @@ SKIP: { ok( $var > 0, 'UV 2'); } + +{ + package Tied; + + sub TIESCALAR { bless {} } + sub FETCH { 7.5 } +} + tie my $tied, 'Tied'; $var = dualvar($tied, "ok"); ok($var == 7.5, 'Tied num'); ok($var eq 'ok', 'Tied str'); -package Tied; - -sub TIESCALAR { bless {} } -sub FETCH { 7.5 } +SKIP: { + skip("need utf8::is_utf8",2) unless defined &utf8::is_utf8; + ok(!!utf8::is_utf8(dualvar(1,chr(400))), 'utf8'); + ok( !utf8::is_utf8(dualvar(1,"abc")), 'not utf8'); +} diff --git a/cpan/List-Util/t/first.t b/cpan/List-Util/t/first.t index 07377ab340..1378c39044 100644 --- a/cpan/List-Util/t/first.t +++ b/cpan/List-Util/t/first.t @@ -15,7 +15,7 @@ BEGIN { use List::Util qw(first); use Test::More; -plan tests => ($::PERL_ONLY ? 15 : 17); +plan tests => 19 + ($::PERL_ONLY ? 0 : 2); my $v; ok(defined &first, 'defined'); @@ -113,3 +113,13 @@ if (!$::PERL_ONLY) { SKIP: { like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); } } + +eval { &first(1,2) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &first(qw(a b)) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &first([],1,2,3) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &first(+{},1,2,3) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); + diff --git a/cpan/List-Util/t/lln.t b/cpan/List-Util/t/lln.t index d31633be6f..1499cdb49d 100644 --- a/cpan/List-Util/t/lln.t +++ b/cpan/List-Util/t/lln.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 18; +use Test::More tests => 19; use Scalar::Util qw(looks_like_number); foreach my $num (qw(1 -1 +1 1.0 +1.0 -1.0 -1.0e-12)) { @@ -43,4 +43,6 @@ tie %foo, 'Foo'; is(!!looks_like_number($foo{'abc'}), '', 'Tied'); is(!!looks_like_number($foo{'123'}), 1, 'Tied'); +is(!!looks_like_number("\x{1815}"), '', 'MONGOLIAN DIGIT FIVE'); + # We should copy some of perl core tests like t/base/num.t here diff --git a/cpan/List-Util/t/reduce.t b/cpan/List-Util/t/reduce.t index 5d6e3d942c..2e1257521c 100644 --- a/cpan/List-Util/t/reduce.t +++ b/cpan/List-Util/t/reduce.t @@ -16,7 +16,7 @@ BEGIN { use List::Util qw(reduce min); use Test::More; -plan tests => ($::PERL_ONLY ? 23 : 25); +plan tests => 27 + ($::PERL_ONLY ? 0 : 2); my $v = reduce {}; @@ -150,3 +150,13 @@ if (!$::PERL_ONLY) { SKIP: { like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); } } + +eval { &reduce(1,2) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &reduce(qw(a b)) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &reduce([],1,2,3) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &reduce(+{},1,2,3) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); + diff --git a/cpan/Module-Build/Changes b/cpan/Module-Build/Changes index df66502dbd..bfc585f3cd 100644 --- a/cpan/Module-Build/Changes +++ b/cpan/Module-Build/Changes @@ -1,24 +1,263 @@ Revision history for Perl extension Module::Build. +0.35_09 - Thu Nov 19 01:30:42 EST 2009 + + Bug fixes: + + - The DB package should not be included in 'provides' in META files + [David Golden] + + - Fixed t/xs.t build failures in bleadperl for noexec temp directories + [Nicholas Clark] + + - Adjusted order of @INC in resume() (fixes par.t, ppm.t, xs.t fails): + @INC = @new_additions_to_inc, @saved_additions_to_inc, @default_inc + [David Golden] + + - Skip bundle_inc.t tests if bundled Module::Build for test can't be + tweaked (Works around test crashes on Win2) [David Golden] + + Other: + + - 'C_support' is no longer an optional feature. Modern ExtUtils::CBuilder + and ExtUtils::ParseXS added to the 'requires' list. This ensures that + upgrading Module::Build will upgrade this critical modules. + ExtUtils::CBuilder no longer requires a compiler, so it is "safe" to + require. + +0.35_08 - Mon Nov 16 22:38:28 EST 2009 + + Bug fixes: + + - Multiple tests were failing due to dependency problems. Author + dependencies have been largely removed from core 'requires' into + optional features. Feature prereq detection and messaging have been + expanded and bugs on older Perls have been removed. + +0.35_07 - Sat Nov 14 17:14:39 EST 2009 + + Bug fixes: + + - Auto-detection of abstract and author fixed for mixed-case POD headers + (RT#51117) [David Wheeler] + + - resume() was not restoring additions to @INC added in Build.PL + (RT#50145) [David Golden] + + - When tarball paths are less than 100 characters, disables 'prefix' + mode of Archive::Tar for maximum compatibility (RT#50571) [David Golden] + +0.35_06 - Fri Nov 13 14:51:28 EST 2009 + + Enhancements: + + - Added experimental inc/ bundling; see Module::Build::Bundling for + details. [David Golden and Eric Wilhelm] + + - Clarified that 'apache' in the license attribute indicates the Apache + License 2.0 and added 'apache_1_1' for the older version of the license + (RT#50614) [David Golden] + + Bug fixes: + + - Merging 'requires' and 'build_requires' in Module::Build::Compat could + lead to duplicate PREREQ_PM entries; now the highest version is used + for PREREQ_PM. (RT#50948) [David Golden] + + - Module::Build::Compat will now die with an error if advanced, + non-numeric prerequisites are given, as these are not supported by + ExtUtils::MakeMaker in PREREQ_PM [David Golden] + + - Made MYMETA generation non-fatal if fields required for META.yml + are missing [David Golden] + + - Added Pod::Simple to requirements for manpage support; avoids + problems if a user has a broken Pod::Man/Pod::Simple. (RT#50081) + [David Golden] + + - Won't die if installed Pod::Readme is broken [David Golden] + + Other: + + - Fixed Module::Build::Notes POD [David Golden] + + - Some commands had become silent by default, so added a few short status + messages so users know something actually happened [David Golden] + + - Cleaned up Changes file formatting [David Golden] + + - Removed most PERL_CORE customizations from test files due to + reorganization of dual-life modules in core (RT#49522) [David Golden] + +0.35_05 - Wed Oct 28 17:20:59 EDT 2009 + + Bug fixes: + + - Fix test failure in t/actions/installdeps.t when $^X is not the default + perl [David Golden] + + - Work around $VERSION numbers in ActiveState with multiple underscores + that prevent Module::Build from installing on Win32 [David Golden] + + - Fix bug cleaning compatibility Makefile when older ExtUtils::Manifest is + installed [David Golden with help from David Cantrell] + + Other: + + - Suppressed more warnings from tests [David Golden] + + - Add provisional support for 'package NAME VERSION' syntax added in + Perl 5.11.1 [David Golden] + +0.35_04 - Fri Oct 23 11:20:41 EDT 2009 + + Bug fixes: + + - Fix test failure if IPC::Cmd isn't installed [David Golden] + + Other: + + - Suppressed warning messages from various tests [David Golden] + +0.35_03 - Wed Oct 21 21:20:59 EDT 2009 + + *** API CHANGE *** + + - The prepare_metadata() method used to take a YAML::Node object as an + argument for modification. The method now takes no arguments and just + returns a hash reference of metadata. [David Golden] + + Enhancements + + - Command line options may be set via the PERL_MB_OPT environment + variable (similar to PERL_MM_OPT in ExtUtils::MakeMaker) + + Bug fixes: + + - Updated PPM generation to PPM v4 (RT#49600) [Olivier Mengue] + + - When c_source is specified, the directory scan will include additional, + less-common C++ extensions (RT49298) [David Golden] + + - When module_name is not supplied, no packlist was being written; fixed + by guessing module_name from dist_version_from or the directory name + (just like ExtUtils::Manifest does without NAME) [David Golden] + + - Bumped IO::File prereq to fix binmode failures in PPMMaker on Perl + prior to 5.8.8 [David Golden] + + Other: + + - Replaced use of YAML.pm with YAML::Tiny; Module::Build::YAML is now + based on YAML::Tiny as well [David Golden] + + - Reduced amount of console output under normal operation (use --verbose + to see all output) [David Golden] + +0.35_02 - Mon Sep 7 22:37:42 EDT 2009 + + Enhancements: + + - Added 'needs_compiler' property. Defaults to true if XS or c_source + exist. If true, ExtUtils::CBuilder is also added to build_requires. + [David Golden] + + - File::ShareDir automatically added to 'requires' if 'share_dir' is set + [David Golden] + + - Added 'Build installdeps' action to install needed dependencies via + a user-configurable command line program. (Defaults to 'cpan'.) + [Eric Wilhelm] + + Bug fixes: + + - Failure to detect a compiler will now warn during Build.PL and be a + fatal error when trying to compile during Build. (RT#48918) [David + Golden] + + - Fixed directory sorting failure in share_dir.t [David Golden] + + - Property defaults that are data structures were being assigned as + references to new objects. Changed so that defaults are cloned instead. + (This mostly affects testing, which often creates multiple objects in the + same process) [David Golden] + + - Simplified error message on exit under use_tap_harness [suggested by + David Wheeler] + + - Fixed typemap search to use a dist-level typemap if a typemap is not + found in the directory with the *.xs file; (was manifesting as warnings + in Perl 5.6 tests) [David Golden] + + Other: + + - Replaced guts of new_from_context(). Build.PL is now executed in a + separate process before resume() is called. (This is generally only of + interest to Module::Build or toolchain developers) (RT#49350) [David + Golden, Eric Wilhelm, Ken Williams] + + - Revised test helper classes to fix potential bugs and add new features + to make writing tests simpler and easier. Changes incorporated into + t/README.pod and t/sample.t as examples for new testing. [David Golden] + +0.35_01 - Mon Aug 31 12:11:10 EDT 2009 + + Enhancements: + + - Generates MYMETA.yml during Build.PL (new standard protocol for + communicating configuration results between toolchain components) + [David Golden] + + - Added 'share_dir' property to provide File::ShareDir support; + set automatically if a directory called 'share' exists + [David Golden] + + Bug fixes: + + - Fix the t/destinations.t fix. [David Golden, with thanks to Eric Wilhelm] + + - Fix recursive test files in generated Makefile.PL (RT#49254) [Sawyer X] + + - Guard against trying :utf8 when :utf8 isn't available + + - The "test" action now dies when using the 'use_tap_harness' + option and tests fail, matching the behavior under Test::Harness. + (RT#49080) [initial patch from David Wheeler; revised by David Golden] + + Other: + + - Added t/README.pod and t/sample.t to guide developers writing new tests + [David Golden, with some code from Eric Wilhelm] + + - Module::Build::Compat 'passthrough' style has been deprecated. Using + 'passthrough' will issue warnings on Makefile.PL generation. See + Module::Build::Compat documentation for rationale. + 0.35 - Thu Aug 27 09:12:02 EDT 2009 Bug fixes: - - Fix t/destinations.t segfault on 5.6.2 + + - Fix t/destinations.t segfault on 5.6.2 [David Golden] 0.34_06 - Sat Aug 22 21:58:26 EDT 2009 Bug fixes: + - Multiple test fixes for OS2 [Ilya Zakharevich] + - Generated.ppd files use :utf8 if possible (RT#48827) [Olivier Mengue] + - Fixed preservation of custom install_paths on resume (RT#41166) [David Golden] + - Warn instead of crashing when Pod::Man tries to create files with colons on vfat partitions on unix (RT#45544) [David Golden] 0.34_05 - Sun Aug 9 22:31:37 EDT 2009 Bug fixes: - - When auto_configure_requires is true (the default), Module::Build will + + - When auto_configure_requires is true (the default), Module::Build will only add last 'major' version of Module:Build (e.g. 0.XX) to configure_requires to avoid specifying a minor development release not available on CPAN [David Golden] @@ -26,6 +265,7 @@ Revision history for Perl extension Module::Build. 0.34_04 - Sat Aug 8 11:02:24 EDT 2009 Other: + - Added documentation warning that 'get_options' should be capitalized to avoid conflicting with future Module::Build options and changed the examples accordingly. @@ -33,12 +273,17 @@ Revision history for Perl extension Module::Build. 0.34_03 - Sat Aug 8 07:39:16 EDT 2009 Bug fixes: + - Fixed failing xs.t if /tmp is mounted noexec (RT#47331) [David Golden] + - Fixed failing debug.t on VMS (RT#48362) [Craig Berry] + - Prevent par.t from dying on error in .zip extraction [David Golden] + - Fixed potential runthrough.t failure on 5.6.2 [David Golden] Other: + - Archive::Tar changed from 'requires' to 'recommends' so non-authors without IO::Zlib can still use Module::Build to install modules [reported by Matt Trout, fix by David Golden] @@ -46,22 +291,26 @@ Revision history for Perl extension Module::Build. 0.340201 - Sun Aug 9 22:11:04 EDT 2009 Other: + - Version bump for Perl core for 5.10.1 release; no other changes 0.34_02 - Sun Jul 26 22:50:40 EDT 2009 Bug-fixes: + - Bundled Module::Build::Version updated to bring into sync with CPAN version.pm 0.77 [John Peacock] 0.34_01 - Sat Jul 18 16:32:09 EDT 2009 Enhancements: + - Added --debug flag to trace Build action execution (RT#47933) [David Golden] Bug-fixes: - - Bundled Module::Build::Version version code updated to fix unsafe use + + - Bundled Module::Build::Version version code updated to fix unsafe use of $@ (RT#47980) [John Peacock] 0.34 - Tue Jul 7 16:56:47 EDT 2009 @@ -71,27 +320,33 @@ Revision history for Perl extension Module::Build. 0.33_06 - Sun Jul 5 10:11:40 EDT 2009 Bug-fixes: + - Bundled version code will use pure Perl on 5.10.0 to work around a corner case involving eval and locale [John Peacock] + - Reversed VMS patch from 0.33_03 [Craig Berry] + - PL_files in Build.PL that are in the bin/scripts directory should not be - installed as if they are scripts (fixed for case-tolerant systems). + installed as if they are scripts (fixed for case-tolerant systems). [David Golden, reported by Craig Berry] 0.33_05 - Sun Jun 28 22:06:49 EDT 2009 Enhancements: + - New 'auto_configure_requires' parameter (default 1) controls whether Module::Build should add itself to configure_requires in META.yml if not specified in Build.PL [David Golden] Bug-fixes: + - The default MANIFEST.SKIP created by the "manifest" action was out of date. It will now use the installed MANIFEST.SKIP and add some Module::Build and distribution specific items to it. [Michael Schwern] Other: + - configure_requires do not necessarily need to be in requires or build_requires; warning to that effect has been removed [David Golden] @@ -99,99 +354,141 @@ Revision history for Perl extension Module::Build. 0.33_04 - Fri Jun 26 07:09:06 EDT 2009 Bug-fixes: + - Don't try utf8 YAML I/O on Perl 5.6 [David Golden] Other: + - configure_requires added to prereq report (RT#47254) [Curtis Jewell] + - updated Module::Build::Version to match forthcoming version.pm 0.77 (RT#47256) [John Peacock] + - skips xs.t and ppm.t when perl was not compiled with dynamic loading - since Module::Buld does not support static linking (RT#46178) + since Module::Buld does not support static linking (RT#46178) [David Golden] + - skip failing test in par.t if Archive::Zip is broken [David Golden] + - Added YAML utf8 patch in 0.33_03 changes list + - Added attribution for patches in 0.33_03 changes list 0.33_03 - Mon Jun 22 17:22:56 EDT 2009 Bug-fixes: - - Removes Module::Build from its own configure/build_requires + + - Removes Module::Build from its own configure/build_requires [David Golden] + - ConfigData->feature() confirms that modules actually load successfully, not just that they are present. (RT#43557) [David Golden] - - Module::Build::Compat handling of INSTALL*LIB (RT#43827) + + - Module::Build::Compat handling of INSTALL*LIB (RT#43827) [Tony Payne, David Golden] + - Module::Build::Compat and recursive test files (RT#39171) [Dave Rolsky] + - Fixed bug linking non-standard XS names on Windows (RT#38065) ["snaury"] - - Run PL files that don't generate any file (RT#39365) + + - Run PL files that don't generate any file (RT#39365) [Matisse Enzer, David Golden] + - HTML generation failure no longer fatal (RT#36660) [David Golden] - - realclean might not delete Build.bat on Windows (RT#43863) + + - realclean might not delete Build.bat on Windows (RT#43863) [Roy Ivy, David Golden] + - include_dirs parameter now works correctly when given a single string argument (RT#40177) [David Wheeler] + - Lots of spelling fixes in the POD (RT#45528r) [Lars Dieckow] + - On Unix-like systems, tilde expansion is more liberal in username characters accepted (RT#33492) [Jon Jensen] Other + - On MSWin32, bumped File::Spec prereq to 3.30 for a variety of fixes + - Add support for VMS in Unix compatibility mode (RT#42157) [John E. Malmberg - - Added a can_action($name) method (RT#45172) [brian d foy] + + - Added a can_action($name) method (RT#45172) [brian d foy] + - Documented that subclass methods should not permanently change current directory (RT#46919) [David Wheeler] + - META.yml encoded in UTF-8 (RT#43765) [Olivier Mengue] 0.33_02 - Mon Jun 15 12:23:55 EDT 2009 Bug-fixes: + - Fixed tests for bleadperl 0.33_01 - Sat Jun 13 20:24:42 EDT 2009 Bug-fixes: + - Fixed RT#42724: consolidated VMS fixes [patch by Craig Berry] + - Fixed RT#46338: passthrough Makefile.PL cleans Makefile during distclean + - Fixed RT#45700: t/compat.t for HP/UX make Other: - - Adds current Module::Build to configure_requires (and build_requires) + + - Adds current Module::Build to configure_requires (and build_requires) if no configure_requires is specified + - Always normalizes version number tuples in META.yml (e.g. 'v1.2.0') - (Partially addresses RT#46150) - - Normalizes a generated dist_version (e.g. from a .pm file) -- + (Partially addresses RT#46150) + + - Normalizes a generated dist_version (e.g. from a .pm file) -- dist_version set manually in Build.PL is not normalized + - Documentation update for create_license + - Minor POD cleanup 0.33 - Sun May 3 20:16:34 PDT 2009 Bug-fixes: + - Fixed RT#45462: Compat.pm needs to reference 'Build.com' on VMS [patch from John Malmberg] + - Fixed RT#45461: ext.t on VMS [patch from John Malmberg] + - Fixed RT#43861: Module::Build::PPMMaker has broken PPD name versioning for v5.10+ 0.32_01 - Tue Apr 14 17:14:22 PDT 2009 Bug-fixes: + - Module::Build::Compat had stopped adding "PL_FILES => {}" when no PL_files property was set in Build.PL; restored old behavior and fixed tests and documentation related to this issue [David Golden] - - Caches ExtUtils::CBuilder object in a temporary stash instead of properties + + - Caches ExtUtils::CBuilder object in a temporary stash instead of properties + - Fixed undef resources->license in META.yml (RT #44453). + - Use $^X instead of 'perl' in t/ext.t [David Golden] (RT #43485) Other: + - Generated META.yml will indicate version 1.4 of the specification (RT #37478) [patch from Alexandr Ciornii] + - Archive::Tar now the default for generating tarballs on all platforms (avoids problems with incompatible tar binaries) + - dist_dir() now uses dist_name() and dist_version() accessors rather than using its properties directly. [brian d foy] (RT #45038) - + 0.32 - Wed Feb 25 17:40:02 PST 2009 No changes since 0.31_04. @@ -199,100 +496,129 @@ Revision history for Perl extension Module::Build. 0.31_04 - Fri Feb 20 11:04:59 PST 2009 Other - - Bumped Test::Harness prereq to 3.16 for latest PERL5LIB fixes (solves + +- Bumped Test::Harness prereq to 3.16 for latest PERL5LIB fixes (solves test failures when installing Module::Build using CPANPLUS::Dist::Build) [David Golden] 0.31_03 - Sun Feb 8 14:54:01 PST 2009 Enhancements + - added a "prereq_data" action that prints a Perl data structure of all prerequisites; can be loaded by external tools using eval() [David Golden] Bug-fixes + - 'fakeinstall' action warns and skips without ExtUtils::Install 1.32+ [David Golden, reported by Zefram] + - allows Module::Build version mismatch when installing self; works around limitations in CPANPLUS::Dist::Build [David Golden] 0.31_02 - Tue Jan 27 09:16:43 PST 2009 Other + - tests now use File::Temp (added to build_requires); appears to fix Win32 testing heisenbug on directory removal during high system loads + - use_tap_harness.t will skip unless a release version of TAP::Harness is installed + - improved diagnostics to ensure_blib() tests in t/lib/MBTest.pm Compat + - passthrough Makefile.PL will now play nice with cpantesters' on exit(0) (RT#32018) [Eric Wilhelm] Bug Fixes + - fix for doubling-up of --prefix (RT#19951) 0.31012 - Wed Jan 14 01:36:19 PST 2009 Bug Fixes + - t/tilde.t maybe actually fixed on MSWin32 now. 0.31011 - Mon Jan 12 21:57:04 PST 2009 Bug Fixes + - t/tilde.t had been failing on MSWin32 (RT#42349) 0.3101 - Mon Jan 12 13:52:36 PST 2009 Other + - added 'mirbsd' as a Unix-type OS [BinGOs] + - added 'haiku' as a Unix-type OS (backported from bleadperl) + - skips certain tests on VMS (backported from bleadperl) + - sets $^X to absolute path in tests (backported from bleadperl) 0.31 - Sat Dec 20 15:03:33 2008 Deprecations + - Use of attributes as class methods is deprecated (this was never a documented feature and appears to only have worked accidentally.) 0.30_02 - Mon Dec 15 12:23:55 PST 2008 Bug Fixes + - make Software::License dependency "softer". 0.30_01 - Thu Dec 11 18:25:53 PST 2008 New Docs + - Added a recipe for writing a new action to the Cookbook + - Added a recipe for bundling Module::Build to the Cookbook. Doc Fixes + - Clarified dist_abstract search procedure in API.pod (RT#41056) [Mario Domgoergen] Bug Fixes + - Workaround HARNESS_TIMER env issue in t/compat.t (RT#39635) + - Fix ~ expansion when $HOME is different from /etc/passwd as when running sudo. [rt.cpan.org 39662] + - Fixed a small POD error in the Cookbook. [Damyan Ivanov] + - Unset group/other write permission bits when using Archive::Tar to build the dist tarball. (RT#39804) [David Golden] Enhancements + - We now support a 'create_license' parameter to new() that will create a LICENSE file during the 'dist' phase with the full text of the license. This requires Software::License on the author's machine. + - Added lgpl2/lgpl3 entries to the supported licenses (RT#40532). + - Support for validating properties with a check subref. [David Wheeler] Test Fixes + - Defend against more stray environment variables interfering with the tests. Other + - Updated our embedded version.pm to 0.76, enhanced documentation on dist_version_from. [John Peacock] @@ -484,11 +810,11 @@ Revision history for Perl extension Module::Build. have stopped, but it didn't. Fixed. [Matthew Cast and David Golden] - - Module::Build::Compat adds "require 5.XXXXX" to Makefile.PL when + - Module::Build::Compat adds "require 5.XXXXX" to Makefile.PL when 'perl' is specified as a 'requires' prerequisite [David Golden] - - Refactored t/compat.t for modularity and transparency; added - labels for all tests; supressed subprocess output to + - Refactored t/compat.t for modularity and transparency; added + labels for all tests; supressed subprocess output to STDOUT and STDERR [David Golden] - Fixed bug in perl_version_to_float when version is already a float @@ -1015,7 +1341,7 @@ Revision history for Perl extension Module::Build. - The synonyms 'scripts' and 'prereq' for 'script_files' and 'requires' were broken in a previous version (0.27_01, probably), but now they're fixed. [David Golden] - + - Previously, we assumed that any custom subclass of Module::Build was located in _build/lib/. This is only true if the author used the subclass() method, though. We now use %INC to find where the @@ -2162,13 +2488,13 @@ Revision history for Perl extension Module::Build. - Added experimental code to build a .ppd file, in support of ActiveState's "Perl Package Manager". [original patch by Dave Rolsky] - + - For authors who use Module::Signature to sign their distributions, we now create the SIGNATURE file right in the distribution directory, rather than creating it in the top-level directory and copying it into place. This solves problems related to having files get out of date with respect to their signatures. - + - We now don't depend on Module::Info to scan for packages during the 'dist' action anymore, because it's way too aggressive about loading other modules that you may not want loaded. We now just @@ -2231,12 +2557,12 @@ Revision history for Perl extension Module::Build. - The distribution directory (e.g. Sample-Module-0.13/ ) will now be deleted during the 'clean' or 'realclean' actions. - + - During testing of modules, blib/lib and blib/arch are now added as absolute paths, not relative. This helps tests that load the modules at runtime and may change the current working directory (like Module::Build itself does during testing). - + - The $Config{cc} entry on some people's systems is something like 'ccache gcc', so we now split that string using split_like_shell(). [Richard Clamp] @@ -2266,7 +2592,7 @@ Revision history for Perl extension Module::Build. - When compiling C code, we now respect 'pollute' and 'inc' parameters. (XXX - needs docs) [Dave Rolsky] - + - Made the creation of the "install map" more generic. (XXX - needs documentation) @@ -2623,7 +2949,7 @@ Revision history for Perl extension Module::Build. - Renamed module_name_to_file() to find_module_by_name(), and added a parameter specifying the directories to search in. Previously we searched in 'lib' and @INC, which wasn't correct in all - situations. + situations. - Patched the docs to change "Build test" to "./Build test" [Elizabeth Mattijsen] @@ -2817,7 +3143,7 @@ Revision history for Perl extension Module::Build. - For the 'Build dist' action, we'll use the 'tar' and 'gzip' programs (as specified by Config.pm) on Unix platforms, otherwise we'll use Archive::Tar and Compress::Zlib. - + 0.02 Wed Sep 5 00:53:04 CDT 2001 - Added POD documentation. diff --git a/cpan/Module-Build/lib/Module/Build.pm b/cpan/Module-Build/lib/Module/Build.pm index be8c1f7079..e8bd9b6306 100644 --- a/cpan/Module-Build/lib/Module/Build.pm +++ b/cpan/Module-Build/lib/Module/Build.pm @@ -15,7 +15,7 @@ use Module::Build::Base; use vars qw($VERSION @ISA); @ISA = qw(Module::Build::Base); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; # Okay, this is the brute-force method of finding out what kind of @@ -167,24 +167,24 @@ This illustrates initial configuration and the running of three 'actions'. In this case the actions run are 'build' (the default action), 'test', and 'install'. Other actions defined so far include: - build manpages - clean pardist - code ppd - config_data ppmdist - diff prereq_data - dist prereq_report - distcheck pure_install - distclean realclean - distdir retest - distmeta skipcheck - distsign test - disttest testall - docs testcover - fakeinstall testdb - help testpod - html testpodcoverage - install versioninstall - manifest + build manifest + clean manpages + code pardist + config_data ppd + diff ppmdist + dist prereq_data + distcheck prereq_report + distclean pure_install + distdir realclean + distmeta retest + distsign skipcheck + disttest test + docs testall + fakeinstall testcover + help testdb + html testpod + install testpodcoverage + installdeps versioninstall You can run the 'help' action for a complete list of actions. @@ -355,8 +355,8 @@ F<META.yml> is a file containing various bits of I<metadata> about the distribution. The metadata includes the distribution name, version, abstract, prerequisites, license, and various other data about the distribution. This file is created as F<META.yml> in YAML format. -It is recommended that the C<YAML> module be installed to create it. -If the C<YAML> module is not installed, an internal module supplied +It is recommended that the C<YAML::Tiny> module be installed to create it. +If the C<YAML::Tiny> module is not installed, an internal module supplied with Module::Build will be used to write the META.yml file, and this will most likely be fine. @@ -445,6 +445,24 @@ This can be a good idea, as it helps prevent multiple versions of a module from being present on your system, which can be a confusing situation indeed. +=item installdeps + +[version 0.36] + +This action will use the C<cpan_client> parameter as a command to install +missing prerequisites. You will be prompted whether to install +optional dependencies. + +The C<cpan_client> option defaults to 'cpan' but can be set as an option or in +F<.modulebuildrc>. It must be a shell command that takes a list of modules to +install as arguments (e.g. 'cpanp -i' for CPANPLUS). If the program part is a +relative path (e.g. 'cpan' or 'cpanp'), it will be located relative to the perl +program that executed Build.PL. + + /opt/perl/5.8.9/bin/perl Build.PL + ./Build installdeps --cpan_client 'cpanp -i' + # installs to 5.8.9 + =item manifest [version 0.05] @@ -731,15 +749,20 @@ C<no> or C<no-> (e.g. C<--noverbose> or C<--no-verbose>). Suppress informative messages on output. +=item verbose + +Display extra information about the Build on output. + +=item cpan_client + +Sets the C<cpan_client> command for use with the C<installdeps> action. +See C<installdeps> for more details. + =item use_rcfile Load the F<~/.modulebuildrc> option file. This option can be set to false to prevent the custom resource file from being loaded. -=item verbose - -Display extra information about the Build on output. - =item allow_mb_mismatch Suppresses the check upon startup that the version of Module::Build @@ -754,7 +777,6 @@ executed build actions. =back - =head2 Default Options File (F<.modulebuildrc>) [version 0.28] @@ -782,15 +804,35 @@ key C<*> (asterisk) denotes any global options that should be applied to all actions, and the key 'Build_PL' specifies options to be applied when you invoke C<perl Build.PL>. - * verbose=1 # global options - diff flags=-u - install --install_base /home/ken - --install_path html=/home/ken/docs/html + * verbose=1 # global options + diff flags=-u + install --install_base /home/ken + --install_path html=/home/ken/docs/html + installdeps --cpan_client 'cpanp -i' If you wish to locate your resource file in a different location, you can set the environment variable C<MODULEBUILDRC> to the complete absolute path of the file containing your options. +=head2 Environment variables + +=over + +=item MODULEBUILDRC + +[version 0.28] + +Specifies an alternate location for a default options file as described above. + +=item PERL_MB_OPT + +[version 0.36] + +Command line options that are applied to Build.PL or any Build action. The +string is split as the shell would (e.g. whitespace) and the result is +prepended to any actual command-line arguments. + +=back =head1 INSTALL PATHS @@ -1091,7 +1133,7 @@ modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), L<Module::Build::Cookbook>, L<Module::Build::Authoring>, -L<Module::Build::API>, L<ExtUtils::MakeMaker>, L<YAML> +L<Module::Build::API>, L<ExtUtils::MakeMaker>, L<YAML::Tiny> F<META.yml> Specification: L<http://module-build.sourceforge.net/META-spec-current.html> diff --git a/cpan/Module-Build/lib/Module/Build/API.pod b/cpan/Module-Build/lib/Module/Build/API.pod index f4e4cea09d..7d269f3cb0 100644 --- a/cpan/Module-Build/lib/Module/Build/API.pod +++ b/cpan/Module-Build/lib/Module/Build/API.pod @@ -454,8 +454,13 @@ Specifies the licensing terms of your distribution. Valid options include: =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 License, Version 2.0 +(L<http://apache.org/licenses/LICENSE-2.0>). + +=item apache_1_1 + +The distribution is licensed under the Apache Software License, Version 1.1 +(L<http://apache.org/licenses/LICENSE-1.1>). =item artistic @@ -580,6 +585,18 @@ used to set C<dist_version>. Setting C<module_name> won't override a C<dist_*> parameter you specify explicitly. +=item needs_compiler + +[version 0.36] + +The C<needs_compiler> parameter indicates whether a compiler is required to +build the distsribution. The default is false, unless XS files are found or +the C<c_source> parameter is set, in which case it is true. If true, +L<ExtUtils::CBuilder> is automatically added to C<build_requires> if needed. + +For a distribution where a compiler is I<optional>, e.g. a dual XS/pure-Perl +distribution, C<needs_compiler> should explicitly be set to a false value. + =item PL_files [version 0.06] @@ -737,6 +754,35 @@ For backward compatibility, you may use the parameter C<scripts> instead of C<script_files>. Please consider this usage deprecated, though it will continue to exist for several version releases. +=item share_dir + +[version 0.36] + +An optional parameter specifying directories of static data files to +be installed as read-only files for use with L<File::ShareDir>. The +C<share_dir> property supports both distribution-level and +module-level share files. + +The default when C<share_dir> is not set is for any files in a F<share> +directory at the top level of the distribution to be installed in +distribution-level share directory. Alternatively, C<share_dir> can be set to +a directory name or an arrayref of directory names containing files to be +installed in the distribution-level share directory. + +If C<share_dir> is a hashref, it may have C<dist> or C<module> keys +providing full flexibility in defining share directories to install. + + share_dir => { + dist => [ 'examples', 'more_examples' ], + module => { + Foo::Templates => ['share/html', 'share/text'], + Foo::Config => 'share/config', + } + } + +If C<share_dir> is set (manually or automatically), then File::ShareDir +will automatically be added to the C<requires> hash. + =item sign [version 0.16] @@ -802,25 +848,23 @@ files in your distribution. [version 0.28] -When called from a directory containing a F<Build.PL> script and a -F<META.yml> file (in other words, the base directory of a -distribution), this method will run the F<Build.PL> and return the -resulting C<Module::Build> object to the caller. Any key-value -arguments given to C<new_from_context()> are essentially like -command line arguments given to the F<Build.PL> script, so for example -you could pass C<< verbose => 1 >> to this method to turn on -verbosity. +When called from a directory containing a F<Build.PL> script (in other words, +the base directory of a distribution), this method will run the F<Build.PL> and +call C<resume()> to return the resulting C<Module::Build> object to the caller. +Any key-value arguments given to C<new_from_context()> are essentially like +command line arguments given to the F<Build.PL> script, so for example you +could pass C<< verbose => 1 >> to this method to turn on verbosity. =item resume() [version 0.03] -You'll probably never call this method directly, it's only called from -the auto-generated C<Build> script. The C<new()> method is only -called once, when the user runs C<perl Build.PL>. Thereafter, when -the user runs C<Build test> or another action, the C<Module::Build> -object is created using the C<resume()> method to re-instantiate with -the settings given earlier to C<new()>. +You'll probably never call this method directly, it's only called from the +auto-generated C<Build> script (and the C<new_from_context> method). The +C<new()> method is only called once, when the user runs C<perl Build.PL>. +Thereafter, when the user runs C<Build test> or another action, the +C<Module::Build> object is created using the C<resume()> method to +re-instantiate with the settings given earlier to C<new()>. =item subclass() @@ -1527,22 +1571,25 @@ Assigning the value C<undef> to an element causes it to be removed. =item prepare_metadata() -[version 0.28] +[version 0.36] -This method is provided for authors to override to customize the -fields of F<META.yml>. It is passed a YAML::Node node object which can -be modified as desired and then returned. E.g. +This method returns a hash reference of metadata that can be used to create a +YAML datastream. It is provided for authors to override or customize the fields +of F<META.yml>. E.g. package My::Builder; use base 'Module::Build'; sub prepare_metadata { my $self = shift; - my $node = $self->SUPER::prepare_metadata( shift ); - $node->{custom_field} = 'foo'; - return $node; + my $data = $self->SUPER::prepare_metadata(); + $data->{custom_field} = 'foo'; + return $data; } +Prior to version 0.36, this method took a YAML::Node as an argument to hold +assembled metadata. + =item prereq_failures() [version 0.11] @@ -1782,6 +1829,10 @@ accessor methods for the following properties: =item build_script() +=item bundle_inc() + +=item bundle_inc_preload() + =item c_source() =item config_dir() @@ -1790,6 +1841,8 @@ accessor methods for the following properties: =item conflicts() +=item cpan_client() + =item create_license() =item create_makefile_pl() @@ -1830,6 +1883,10 @@ accessor methods for the following properties: =item module_name() +=item mymetafile() + +=item needs_compiler() + =item orig_dir() =item perl() @@ -1920,7 +1977,7 @@ modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), L<Module::Build>(3), L<Module::Build::Authoring>(3), -L<Module::Build::Cookbook>(3), L<ExtUtils::MakeMaker>(3), L<YAML>(3) +L<Module::Build::Cookbook>(3), L<ExtUtils::MakeMaker>(3), L<YAML::Tiny>(3) F<META.yml> Specification: L<http://module-build.sourceforge.net/META-spec-current.html> diff --git a/cpan/Module-Build/lib/Module/Build/Base.pm b/cpan/Module-Build/lib/Module/Build/Base.pm index 531c35487e..5894ce51b3 100644 --- a/cpan/Module-Build/lib/Module/Build/Base.pm +++ b/cpan/Module-Build/lib/Module/Build/Base.pm @@ -4,7 +4,7 @@ package Module::Build::Base; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; BEGIN { require 5.00503 } @@ -23,6 +23,7 @@ use Text::ParseWords (); use Module::Build::ModuleInfo; use Module::Build::Notes; use Module::Build::Config; +use Module::Build::Version; #################### Constructors ########################### @@ -31,16 +32,37 @@ sub new { $self->{invoked_action} = $self->{action} ||= 'Build_PL'; $self->cull_args(@ARGV); - + die "Too early to specify a build action '$self->{action}'. Do 'Build $self->{action}' instead.\n" if $self->{action} && $self->{action} ne 'Build_PL'; $self->check_manifest; - $self->check_prereq; - $self->check_autofeatures; + $self->auto_require; + if ( $self->check_prereq + $self->check_autofeatures != 2) { + $self->log_warn(<<EOF); + +ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions +of the modules indicated above before proceeding with this installation + +EOF + unless ( + $self->dist_name eq 'Module-Build' || + $ENV{PERL5_CPANPLUS_IS_RUNNING} || $ENV{PERL5_CPAN_IS_RUNNING} + ) { + $self->log_warn( + "Run 'Build installdeps' to install missing prerequisites.\n\n" + ); + } + } + + # record for later use in resume; + $self->{properties}{_added_to_INC} = [ $self->_added_to_INC ]; + + $self->set_bundle_inc; $self->dist_name; $self->dist_version; + $self->_guess_module_name unless $self->module_name; $self->_find_nested_builds; @@ -52,6 +74,10 @@ sub resume { my $self = $package->_construct(@_); $self->read_config; + my @added_earlier = @{ $self->{properties}{_added_to_INC} || [] }; + + @INC = ($self->_added_to_INC, @added_earlier, $self->_default_INC); + # If someone called Module::Build->current() or # Module::Build->new_from_context() and the correct class to use is # actually a *subclass* of Module::Build, we may need to load that @@ -72,7 +98,7 @@ sub resume { $self->log_warn(" * WARNING: Configuration was initially created with '$self->{properties}{perl}',\n". " but we are now using '$perl'.\n"); } - + $self->cull_args(@ARGV); unless ($self->allow_mb_mismatch) { @@ -82,7 +108,7 @@ sub resume { " or use --allow_mb_mismatch 1 to skip this version check.\n") if $mb_version ne $self->{properties}{mb_version}; } - + $self->{invoked_action} = $self->{action} ||= 'build'; return $self; @@ -90,18 +116,8 @@ sub resume { sub new_from_context { my ($package, %args) = @_; - - # XXX Read the META.yml and see whether we need to run the Build.PL? - - # Run the Build.PL. We use do() rather than run_perl_script() so - # that it runs in this process rather than a subprocess, because we - # need to make sure that the environment is the same during Build.PL - # as it is during resume() (and thereafter). - { - local @ARGV = $package->unparse_args(\%args); - do './Build.PL'; - die $@ if $@; - } + + $package->run_perl_script('Build.PL',[],[$package->unparse_args(\%args)]); return $package->resume; } @@ -497,6 +513,28 @@ sub _discover_perl_interpreter { "in (@paths)\n"; } +# Adapted from IPC::Cmd::can_run() +sub find_command { + my ($self, $command) = @_; + + if( File::Spec->file_name_is_absolute($command) ) { + return $self->_maybe_command($command); + + } else { + for my $dir ( File::Spec->path ) { + my $abs = File::Spec->catfile($dir, $command); + return $abs if $abs = $self->_maybe_command($abs); + } + } +} + +# Copied from ExtUtils::MM_Unix::maybe_command +sub _maybe_command { + my($self,$file) = @_; + return $file if -x $file && ! -d $file; + return; +} + sub _is_interactive { return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe? } @@ -588,10 +626,18 @@ sub features { } if (my $info = $ph->{auto_features}->access($key)) { - my $failures = $self->prereq_failures($info); - my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/, - keys %$failures ) ? 1 : 0; - return !$disabled; + my $disabled; + for my $type ( @{$self->prereq_action_types} ) { + next if $type eq 'description' || $type eq 'recommends' || ! exists $info->{$type}; + my $prereqs = $info->{$type}; + for my $modname ( sort keys %$prereqs ) { + my $spec = $prereqs->{$modname}; + my $status = $self->check_installed_status($modname, $spec); + if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; } + if ( ! eval "require $modname; 1" ) { return 0; } + } + } + return 1; } return $ph->{features}->access($key, @_); @@ -614,7 +660,7 @@ BEGIN { *feature = \&features } # Alias sub _mb_feature { my $self = shift; - + if (($self->module_name || '') eq 'Module::Build') { # We're building Module::Build itself, so ...::ConfigData isn't # valid, but $self->features() should be. @@ -625,6 +671,15 @@ sub _mb_feature { } } +sub _warn_mb_feature_deps { + my $self = shift; + my $name = shift; + $self->log_warn( + "The '$name' feature is not available. Please install missing\n" . + "feature dependencies and try again.\n". + $self->_feature_deps_msg($name) . "\n" + ); +} sub add_build_element { my ($self, $elem) = @_; @@ -635,7 +690,7 @@ sub add_build_element { sub ACTION_config_data { my $self = shift; return unless $self->has_config_data; - + my $module_name = $self->module_name or die "The config_data feature requires that 'module_name' be set"; my $notes_name = $module_name . '::ConfigData'; # TODO: Customize name ??? @@ -646,7 +701,7 @@ sub ACTION_config_data { $self->config_file('features') ], $notes_pm); - $self->log_info("Writing config notes to $notes_pm\n"); + $self->log_verbose("Writing config notes to $notes_pm\n"); File::Path::mkpath(File::Basename::dirname($notes_pm)); Module::Build::Notes->write_config_data @@ -661,7 +716,7 @@ sub ACTION_config_data { } ######################################################################## -{ # enclosing these lexicals -- TODO +{ # enclosing these lexicals -- TODO my %valid_properties = ( __PACKAGE__, {} ); my %additive_properties; @@ -681,10 +736,10 @@ sub ACTION_config_data { sub valid_properties_defaults { my %out; - for (reverse shift->_mb_classes) { - @out{ keys %{ $valid_properties{$_} } } = map { + for my $class (reverse shift->_mb_classes) { + @out{ keys %{ $valid_properties{$class} } } = map { $_->() - } values %{ $valid_properties{$_} }; + } values %{ $valid_properties{$class} }; } return \%out; } @@ -710,9 +765,11 @@ sub ACTION_config_data { my %p = @_ == 1 ? ( default => shift ) : @_; my $type = ref $p{default}; - $valid_properties{$class}{$property} = $type eq 'CODE' - ? $p{default} - : sub { $p{default} }; + $valid_properties{$class}{$property} = + $type eq 'CODE' ? $p{default} : + $type eq 'HASH' ? sub { return { %{ $p{default} } } } : + $type eq 'ARRAY'? sub { return [ @{ $p{default} } ] } : + sub { return $p{default} } ; push @{$additive_properties{$class}->{$type}}, $property if $type; @@ -831,12 +888,16 @@ sub _make_accessor { __PACKAGE__->add_property(auto_configure_requires => 1); __PACKAGE__->add_property(blib => 'blib'); __PACKAGE__->add_property(build_class => 'Module::Build'); -__PACKAGE__->add_property(build_elements => [qw(PL support pm xs pod script)]); +__PACKAGE__->add_property(build_elements => [qw(PL support pm xs share_dir pod script)]); __PACKAGE__->add_property(build_script => 'Build'); __PACKAGE__->add_property(build_bat => 0); +__PACKAGE__->add_property(bundle_inc => []); +__PACKAGE__->add_property(bundle_inc_preload => []); __PACKAGE__->add_property(config_dir => '_build'); __PACKAGE__->add_property(include_dirs => []); +__PACKAGE__->add_property(license => 'unknown'); __PACKAGE__->add_property(metafile => 'META.yml'); +__PACKAGE__->add_property(mymetafile => 'MYMETA.yml'); __PACKAGE__->add_property(recurse_into => []); __PACKAGE__->add_property(use_rcfile => 1); __PACKAGE__->add_property(create_packlist => 1); @@ -844,6 +905,7 @@ __PACKAGE__->add_property(allow_mb_mismatch => 0); __PACKAGE__->add_property(config => undef); __PACKAGE__->add_property(test_file_exts => ['.t']); __PACKAGE__->add_property(use_tap_harness => 0); +__PACKAGE__->add_property(cpan_client => 'cpan'); __PACKAGE__->add_property(tap_harness_args => {}); __PACKAGE__->add_property( 'installdirs', @@ -906,10 +968,10 @@ __PACKAGE__->add_property($_) for qw( has_config_data install_base libdoc_dirs - license magic_number mb_version module_name + needs_compiler orig_dir perl pm_files @@ -921,6 +983,7 @@ __PACKAGE__->add_property($_) for qw( recursive_test_files script_files scripts + share_dir sign test_files verbose @@ -993,14 +1056,14 @@ sub subclass { $opts{code} ||= ''; $opts{class} ||= 'MyModuleBuilder'; - + my $filename = File::Spec->catfile($build_dir, 'lib', split '::', $opts{class}) . '.pm'; my $filedir = File::Basename::dirname($filename); - $pack->log_info("Creating custom builder $filename in $filedir\n"); - + $pack->log_verbose("Creating custom builder $filename in $filedir\n"); + File::Path::mkpath($filedir); die "Can't create directory $filedir: $!" unless -d $filedir; - + my $fh = IO::File->new("> $filename") or die "Can't create $filename: $!"; print $fh <<EOF; package $opts{class}; @@ -1010,7 +1073,7 @@ $opts{code} 1; EOF close $fh; - + unshift @INC, File::Spec->catdir(File::Spec->rel2abs($build_dir), 'lib'); eval "use $opts{class}"; die $@ if $@; @@ -1018,16 +1081,43 @@ EOF return $opts{class}; } +sub _guess_module_name { + my $self = shift; + my $p = $self->{properties}; + return if $p->{module_name}; + if ( $p->{dist_version_from} && -e $p->{dist_version_from} ) { + my $mi = Module::Build::ModuleInfo->new_from_file($self->dist_version_from); + $p->{module_name} = $mi->name; + } + else { + my $mod_path = my $mod_name = File::Basename::basename($self->base_dir); + $mod_name =~ s{-}{::}g; + $mod_path =~ s{-}{/}g; + $mod_path .= ".pm"; + if ( -e $mod_path || -e File::Spec->catfile('lib', $mod_path) ) { + $p->{module_name} = $mod_name; + } + else { + $self->log_warn( << 'END_WARN' ); +No 'module_name' was provided and it could not be inferred +from other properties. This will prevent a packlist from +being written for this file. Please set either 'module_name' +or 'dist_version_from' in Build.PL. +END_WARN + } + } +} + sub dist_name { my $self = shift; my $p = $self->{properties}; return $p->{dist_name} if defined $p->{dist_name}; - + die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter" unless $self->module_name; - + ($p->{dist_name} = $self->module_name) =~ s/::/-/g; - + return $p->{dist_name}; } @@ -1069,12 +1159,12 @@ sub _pod_parse { my $p = $self->{properties}; my $member = "dist_$part"; return $p->{$member} if defined $p->{$member}; - + my $docfile = $self->_main_docfile or return; my $fh = IO::File->new($docfile) or return; - + require Module::Build::PodParser; my $parser = Module::Build::PodParser->new(fh => $fh); my $method = "get_$part"; @@ -1109,7 +1199,7 @@ sub config_file { sub read_config { my ($self) = @_; - + my $file = $self->config_file('build_params') or die "Can't find 'build_params' in " . $self->config_dir; my $fh = IO::File->new($file) or die "Can't read '$file': $!"; @@ -1128,7 +1218,7 @@ sub has_config_data { sub _write_data { my ($self, $filename, $data) = @_; - + my $file = $self->config_file($filename); my $fh = IO::File->new("> $file") or die "Can't create '$file': $!"; unless (ref($data)) { # e.g. magicnum @@ -1141,10 +1231,10 @@ sub _write_data { sub write_config { my ($self) = @_; - + File::Path::mkpath($self->{properties}{config_dir}); -d $self->{properties}{config_dir} or die "Can't mkdir $self->{properties}{config_dir}: $!"; - + my @items = @{ $self->prereq_action_types }; $self->_write_data('prereqs', { map { $_, $self->$_() } @items }); $self->_write_data('build_params', [$self->{args}, $self->{config}->values_set, $self->{properties}]); @@ -1155,13 +1245,74 @@ sub write_config { $self->{phash}{$_}->write() foreach qw(notes cleanup features auto_features config_data runtime_params); } +{ + # packfile map -- keys are guts of regular expressions; If they match, + # values are module names corresponding to the packlist + my %packlist_map = ( + '^File::Spec' => 'Cwd', + '^Devel::AssertOS' => 'Devel::CheckOS', + ); + + sub _find_packlist { + my ($self, $inst, $mod) = @_; + my $lookup = $mod; + my $packlist = eval { $inst->packlist($lookup) }; + if ( ! $packlist ) { + # try from packlist_map + while ( my ($re, $new_mod) = each %packlist_map ) { + if ( $mod =~ qr/$re/ ) { + $lookup = $new_mod; + $packlist = eval { $inst->packlist($lookup) }; + last; + } + } + } + return $packlist ? $lookup : undef; + } + + sub set_bundle_inc { + my $self = shift; + + my $bundle_inc = $self->{properties}{bundle_inc}; + my $bundle_inc_preload = $self->{properties}{bundle_inc_preload}; + # We're in author mode if inc::latest is loaded, but not from cwd + return unless inc::latest->can('loaded_modules'); + require ExtUtils::Installed; + # ExtUtils::Installed is buggy about finding additions to default @INC + my $inst = ExtUtils::Installed->new(extra_libs => [@INC]); + my @bundle_list = map { [ $_, 0 ] } inc::latest->loaded_modules; + + # XXX TODO: Need to get ordering of prerequisites correct so they are + # are loaded in the right order. Use an actual tree?! + + while( @bundle_list ) { + my ($mod, $prereq) = @{ shift @bundle_list }; + + # XXX TODO: Append prereqs to list + # skip if core or already in bundle or preload lists + # push @bundle_list, [$_, 1] for prereqs() + + # Locate packlist for bundling + my $lookup = $self->_find_packlist($inst,$mod); + if ( ! $lookup ) { + # XXX Really needs a more helpful error message here + die << "NO_PACKLIST"; +Could not find a packlist for '$mod'. If it's a core module, try +force installing it from CPAN. +NO_PACKLIST + } + else { + push @{ $prereq ? $bundle_inc_preload : $bundle_inc }, $lookup; + } + } + } # sub check_bundling +} + sub check_autofeatures { my ($self) = @_; my $features = $self->auto_features; - - return unless %$features; - $self->log_info("Checking features:\n"); + return 1 unless %$features; # TODO refactor into ::Util my $longest = sub { @@ -1177,30 +1328,117 @@ sub check_autofeatures { }; my $max_name_len = length($longest->(keys %$features)); - while (my ($name, $info) = each %$features) { - $self->log_info(" $name" . '.' x ($max_name_len - length($name) + 4)); + my ($num_disabled, $log_text) = (0, "\nChecking optional features...\n"); + for my $name ( sort keys %$features ) { + $log_text .= $self->_feature_deps_msg($name, $max_name_len); + } + + $num_disabled = () = $log_text =~ /disabled/g; + + # warn user if features disabled + if ( $num_disabled ) { + $self->log_warn( $log_text ); + return 0; + } + else { + $self->log_verbose( $log_text ); + return 1; + } +} + +sub _feature_deps_msg { + my ($self, $name, $max_name_len) = @_; + $max_name_len ||= length $name; + my $features = $self->auto_features; + my $info = $features->{$name}; + my $feature_text = "$name" . '.' x ($max_name_len - length($name) + 4); + my ($log_text, $disabled) = ('',''); if ( my $failures = $self->prereq_failures($info) ) { - my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/, - keys %$failures ) ? 1 : 0; - $self->log_info( $disabled ? "disabled\n" : "enabled\n" ); - - my $log_text; - while (my ($type, $prereqs) = each %$failures) { - while (my ($module, $status) = each %$prereqs) { - my $required = - ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0; - my $prefix = ($required) ? '-' : '*'; - $log_text .= " $prefix $status->{message}\n"; - } + $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/, + keys %$failures ) ? 1 : 0; + $feature_text .= $disabled ? "disabled\n" : "enabled\n"; + + for my $type ( @{ $self->prereq_action_types } ) { + next unless exists $failures->{$type}; + $feature_text .= " $type:\n"; + my $prereqs = $failures->{$type}; + for my $module ( sort keys %$prereqs ) { + my $status = $prereqs->{$module}; + my $required = + ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0; + my $prefix = ($required) ? '!' : '*'; + $feature_text .= " $prefix $status->{message}\n"; + } } - $self->log_warn("$log_text") unless $self->quiet; } else { - $self->log_info("enabled\n"); + $feature_text .= "enabled\n"; } + $log_text .= $feature_text if $disabled || $self->verbose; + return $log_text; +} + +# Automatically detect and add prerequisites based on configuration +sub auto_require { + my ($self) = @_; + my $p = $self->{properties}; + + # add current Module::Build to configure_requires if there + # isn't one already specified (but not ourself, so we're not circular) + if ( $self->dist_name ne 'Module-Build' + && $self->auto_configure_requires + && ! exists $p->{configure_requires}{'Module::Build'} + ) { + (my $ver = $VERSION) =~ s/^(\d+\.\d\d).*$/$1/; # last major release only + $self->_add_prereq('configure_requires', 'Module::Build', $ver); } - $self->log_warn("\n") unless $self->quiet; + # if we're in author mode, add inc::latest modules to + # configure_requires if not already set. If we're not in author mode + # then configure_requires will have been satisfied, or we'll just + # live with what we've bundled + if ( inc::latest->can('loaded_module') ) { + for my $mod ( inc::latest->loaded_modules ) { + next if exists $p->{configure_requires}{$mod}; + $self->_add_prereq('configure_requires', $mod, $mod->VERSION); + } + } + + # If needs_compiler is not explictly set, automatically set it + # If set, we need ExtUtils::CBuilder (and a compiler) + my $xs_files = $self->find_xs_files; + if ( ! defined $p->{needs_compiler} ) { + $self->needs_compiler( keys %$xs_files || defined $self->c_source ); + } + if ($self->needs_compiler) { + $self->_add_prereq('build_requires', 'ExtUtils::CBuilder', 0); + if ( ! $self->have_c_compiler ) { + $self->log_warn(<<'EOM'); +Warning: ExtUtils::CBuilder not installed or no compiler detected +Proceeding with configuration, but compilation may fail during Build + +EOM + } + } + + # If using share_dir, require File::ShareDir + if ( $self->share_dir ) { + $self->_add_prereq( 'requires', 'File::ShareDir', '1.00' ); + } + + return; +} + +sub _add_prereq { + my ($self, $type, $module, $version) = @_; + my $p = $self->{properties}; + $version = 0 unless defined $version; + if ( exists $p->{$type}{$module} ) { + return if $self->compare_versions( $version, '<=', $p->{$type}{$module} ); + } + $self->log_verbose("Adding to $type\: $module => $version\n"); + $p->{$type}{$module} = $version; + return 1; } sub prereq_failures { @@ -1213,7 +1451,8 @@ sub prereq_failures { foreach my $type (@types) { my $prereqs = $info->{$type}; - while ( my ($modname, $spec) = each %$prereqs ) { + for my $modname ( keys %$prereqs ) { + my $spec = $prereqs->{$modname}; my $status = $self->check_installed_status($modname, $spec); if ($type =~ /^(?:\w+_)?conflicts$/) { @@ -1224,7 +1463,7 @@ sub prereq_failures { } elsif ($type =~ /^(?:\w+_)?recommends$/) { next if $status->{ok}; $status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>' - ? "Optional prerequisite $modname is not installed" + ? "$modname is not installed" : "$modname ($status->{have}) is installed, but we prefer to have $spec"); } else { next if $status->{ok}; @@ -1253,44 +1492,29 @@ sub _enum_prereqs { sub check_prereq { my $self = shift; - # If we have XS files, make sure we can process them. - my $xs_files = $self->find_xs_files; - if (keys %$xs_files && !$self->_mb_feature('C_support')) { - $self->log_warn("Warning: this distribution contains XS files, ". - "but Module::Build is not configured with C_support. ". - "Please install ExtUtils::CBuilder to enable C_support.\n"); - } - # Check to see if there are any prereqs to check my $info = $self->_enum_prereqs; return 1 unless $info; - $self->log_info("Checking prerequisites...\n"); + my $log_text = "Checking prerequisites...\n"; my $failures = $self->prereq_failures($info); if ( $failures ) { - - while (my ($type, $prereqs) = each %$failures) { - while (my ($module, $status) = each %$prereqs) { - my $prefix = ($type =~ /^(?:\w+_)?recommends$/) ? '*' : '- ERROR:'; - $self->log_warn(" $prefix $status->{message}\n"); + $self->log_warn($log_text); + for my $type ( @{ $self->prereq_action_types } ) { + my $prereqs = $failures->{$type}; + $self->log_warn(" ${type}:\n") if keys %$prereqs; + for my $module ( sort keys %$prereqs ) { + my $status = $prereqs->{$module}; + my $prefix = ($type =~ /^(?:\w+_)?recommends$/) ? "* " : "! "; + $self->log_warn(" $prefix $status->{message}\n"); } } - - $self->log_warn(<<EOF); - -ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions -of the modules indicated above before proceeding with this installation - -EOF return 0; - } else { - - $self->log_info("Looks good\n\n"); + $self->log_verbose($log_text . "Looks good\n\n"); return 1; - } } @@ -1323,44 +1547,44 @@ sub _parse_conditions { sub check_installed_status { my ($self, $modname, $spec) = @_; my %status = (need => $spec); - + if ($modname eq 'perl') { $status{have} = $self->perl_version; - + } elsif (eval { no strict; $status{have} = ${"${modname}::VERSION"} }) { # Don't try to load if it's already loaded - + } else { my $pm_info = Module::Build::ModuleInfo->new_from_module( $modname ); unless (defined( $pm_info )) { @status{ qw(have message) } = ('<none>', "$modname is not installed"); return \%status; } - + $status{have} = $pm_info->version(); if ($spec and !defined($status{have})) { @status{ qw(have message) } = (undef, "Couldn't find a \$VERSION in prerequisite $modname"); return \%status; } } - + my @conditions = $self->_parse_conditions($spec); - + foreach (@conditions) { my ($op, $version) = /^\s* (<=?|>=?|==|!=) \s* ([\w.]+) \s*$/x or die "Invalid prerequisite condition '$_' for $modname"; - + $version = $self->perl_version_to_float($version) if $modname eq 'perl'; - + next if $op eq '>=' and !$version; # Module doesn't have to actually define a $VERSION - + unless ($self->compare_versions( $status{have}, $op, $version )) { $status{message} = "$modname ($status{have}) is installed, but we need version $op $version"; return \%status; } } - + $status{ok} = 1; return \%status; } @@ -1368,7 +1592,7 @@ sub check_installed_status { sub compare_versions { my $self = shift; my ($v1, $op, $v2) = @_; - $v1 = Module::Build::Version->new($v1) + $v1 = Module::Build::Version->new($v1) unless UNIVERSAL::isa($v1,'Module::Build::Version'); my $eval_str = "\$v1 $op \$v2"; @@ -1381,14 +1605,14 @@ sub compare_versions { # I wish I could set $! to a string, but I can't, so I use $@ sub check_installed_version { my ($self, $modname, $spec) = @_; - + my $status = $self->check_installed_status($modname, $spec); - + if ($status->{ok}) { return $status->{have} if $status->{have} and "$status->{have}" ne '<none>'; return '0 but true'; } - + $@ = $status->{message}; return 0; } @@ -1430,23 +1654,23 @@ sub _added_to_INC { sub _default_INC { my $self = shift; return @default_inc if @default_inc; - + local $ENV{PERL5LIB}; # this is not considered part of the default. - + my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter; - + my @inc = $self->_backticks($perl, '-le', 'print for @INC'); chomp @inc; - + return @default_inc = @inc; } } sub print_build_script { my ($self, $fh) = @_; - + my $build_package = $self->build_class; - + my $closedata=""; my %q = map {$_, $self->$_()} qw(config_dir base_dir); @@ -1532,20 +1756,29 @@ EOF sub create_build_script { my ($self) = @_; $self->write_config; - + + # Create MYMETA.yml + my $mymetafile = $self->mymetafile; + if ( $self->delete_filetree($mymetafile) ) { + $self->log_verbose("Removed previous '$mymetafile'\n"); + } + $self->log_info("Creating new '$mymetafile' with configuration results\n"); + $self->write_metafile( $mymetafile, $self->prepare_metadata( fatal => 0 ) ); + + # Create Build my ($build_script, $dist_name, $dist_version) = map $self->$_(), qw(build_script dist_name dist_version); - + if ( $self->delete_filetree($build_script) ) { - $self->log_info("Removed previous script '$build_script'\n\n"); + $self->log_verbose("Removed previous script '$build_script'\n"); } $self->log_info("Creating new '$build_script' script for ", - "'$dist_name' version '$dist_version'\n"); + "'$dist_name' version '$dist_version'\n"); my $fh = IO::File->new(">$build_script") or die "Can't create '$build_script': $!"; $self->print_build_script($fh); close $fh; - + $self->make_executable($build_script); return 1; @@ -1554,20 +1787,20 @@ sub create_build_script { sub check_manifest { my $self = shift; return unless -e 'MANIFEST'; - + # Stolen nearly verbatim from MakeMaker. But ExtUtils::Manifest # could easily be re-written into a modern Perl dialect. require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean. local ($^W, $ExtUtils::Manifest::Quiet) = (0,1); - - $self->log_info("Checking whether your kit is complete...\n"); + + $self->log_verbose("Checking whether your kit is complete...\n"); if (my @missed = ExtUtils::Manifest::manicheck()) { $self->log_warn("WARNING: the following files are missing in your kit:\n", "\t", join("\n\t", @missed), "\n", "Please inform the author.\n\n"); } else { - $self->log_info("Looks good\n\n"); + $self->log_verbose("Looks good\n\n"); } } @@ -1692,6 +1925,7 @@ sub _translate_option { use_rcfile use_tap_harness tap_harness_args + cpan_client ); # normalize only selected option names return $opt; @@ -1824,7 +2058,7 @@ sub read_args { require Module::Build::Compat; %args = (%args, Module::Build::Compat->makefile_to_build_macros); } - + return \%args, $action; } @@ -1977,7 +2211,10 @@ sub merge_args { sub cull_args { my $self = shift; - my ($args, $action) = $self->read_args(@_); + my @arg_list = @_; + unshift @arg_list, $self->split_like_shell($ENV{PERL_MB_OPT}) + if $ENV{PERL_MB_OPT}; + my ($args, $action) = $self->read_args(@arg_list); $self->merge_args($action, %$args); $self->merge_modulebuildrc( $action, %$args ); } @@ -1986,7 +2223,7 @@ sub super_classes { my ($self, $class, $seen) = @_; $class ||= ref($self) || $self; $seen ||= {}; - + no strict 'refs'; my @super = grep {not $seen->{$_}++} $class, @{ $class . '::ISA' }; return @super, map {$self->super_classes($_,$seen)} @super; @@ -1997,7 +2234,7 @@ sub known_actions { my %actions; no strict 'refs'; - + foreach my $class ($self->super_classes) { foreach ( keys %{ $class . '::' } ) { $actions{$1}++ if /^ACTION_(\w+)/; @@ -2073,7 +2310,7 @@ sub get_action_docs { $@ = "Couldn't find any docs for action '$action'"; return; } - + return join '', @docs; } @@ -2147,7 +2384,7 @@ sub prereq_report { sub ACTION_help { my ($self) = @_; my $actions = $self->known_actions; - + if (@{$self->{args}{ARGV}}) { my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)}; print $@ ? "$@\n" : $msg; @@ -2158,10 +2395,10 @@ sub ACTION_help { Usage: $0 <action> arg1=value arg2=value ... Example: $0 test verbose=1 - + Actions defined: EOF - + print $self->_action_listing($actions); print "\nRun `Build help <action>` for details on an individual action.\n"; @@ -2174,7 +2411,7 @@ sub _action_listing { # Flow down columns, not across rows my @actions = sort keys %$actions; @actions = map $actions[($_ + ($_ % 2) * @actions) / 2], 0..$#actions; - + my $out = ''; while (my ($one, $two) = splice @actions, 0, 2) { $out .= sprintf(" %-12s %-12s\n", $one, $two||''); @@ -2184,7 +2421,7 @@ sub _action_listing { sub ACTION_retest { my ($self) = @_; - + # Protect others against our @INC changes local @INC = @INC; @@ -2232,7 +2469,7 @@ sub generic_test { my $p = $self->{properties}; my @types = ( - (exists($args{type}) ? $args{type} : ()), + (exists($args{type}) ? $args{type} : ()), (exists($args{types}) ? @{$args{types}} : ()), ); @types or croak "need some types of tests to check"; @@ -2265,6 +2502,8 @@ sub generic_test { $self->do_tests; } +# Test::Harness dies on failure but TAP::Harness does not, so we must +# die if running under TAP::Harness sub do_tests { my $self = shift; @@ -2273,7 +2512,10 @@ sub do_tests { if(@$tests) { my $args = $self->tap_harness_args; if($self->use_tap_harness or ($args and %$args)) { - $self->run_tap_harness($tests); + my $aggregate = $self->run_tap_harness($tests); + if ( $aggregate->has_errors ) { + die "Errors in testing. Cannot continue.\n"; + } } else { $self->run_test_harness($tests); @@ -2293,12 +2535,14 @@ sub run_tap_harness { # TODO allow the test @INC to be set via our API? - TAP::Harness->new({ + my $aggregate = TAP::Harness->new({ lib => [@INC], verbosity => $self->{properties}{verbose}, switches => [ $self->harness_switches ], %{ $self->tap_harness_args }, })->runtests(@$tests); + + return $aggregate; } sub run_test_harness { @@ -2382,14 +2626,14 @@ sub ACTION_testcover { my $pm_files = $self->rscan_dir (File::Spec->catdir($self->blib, 'lib'), file_qr('\.pm$') ); my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/}); - + $self->do_system(qw(cover -delete)) unless $self->up_to_date($pm_files, $cover_files) && $self->up_to_date($self->test_files, $cover_files); } - local $Test::Harness::switches = - local $Test::Harness::Switches = + local $Test::Harness::switches = + local $Test::Harness::Switches = local $ENV{HARNESS_PERL_SWITCHES} = "-MDevel::Cover"; $self->depends_on('test'); @@ -2398,17 +2642,17 @@ sub ACTION_testcover { sub ACTION_code { my ($self) = @_; - + # All installable stuff gets created in blib/ . # Create blib/arch to keep blib.pm happy my $blib = $self->blib; $self->add_to_cleanup($blib); File::Path::mkpath( File::Spec->catdir($blib, 'arch') ); - + if (my $split = $self->autosplit) { $self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split); } - + foreach my $element (@{$self->build_elements}) { my $method = "process_${element}_files"; $method = "process_files_by_extension" unless $self->can($method); @@ -2420,16 +2664,17 @@ sub ACTION_code { sub ACTION_build { my $self = shift; + $self->log_info("Building " . $self->dist_name . "\n"); $self->depends_on('code'); $self->depends_on('docs'); } sub process_files_by_extension { my ($self, $ext) = @_; - + my $method = "find_${ext}_files"; my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext, 'lib'); - + while (my ($file, $dest) = each %$files) { $self->copy_if_modified(from => $file, to => File::Spec->catfile($self->blib, $dest) ); } @@ -2439,19 +2684,70 @@ sub process_support_files { my $self = shift; my $p = $self->{properties}; return unless $p->{c_source}; - + push @{$p->{include_dirs}}, $p->{c_source}; - - my $files = $self->rscan_dir($p->{c_source}, file_qr('\.c(pp)?$')); + + my $files = $self->rscan_dir($p->{c_source}, file_qr('\.c(c|p|pp|xx|\+\+)?$')); foreach my $file (@$files) { push @{$p->{objects}}, $self->compile_c($file); } } +sub process_share_dir_files { + my $self = shift; + my $files = $self->_find_share_dir_files; + return unless $files; + + # root for all File::ShareDir paths + my $share_prefix = File::Spec->catdir($self->blib, qw/lib auto share/); + + # copy all share files to blib + while (my ($file, $dest) = each %$files) { + $self->copy_if_modified( + from => $file, to => File::Spec->catfile( $share_prefix, $dest ) + ); + } +} + +sub _find_share_dir_files { + my $self = shift; + my $share_dir = $self->share_dir; + return unless $share_dir; + + my @file_map; + if ( $share_dir->{dist} ) { + my $prefix = File::Spec->catdir( "dist", $self->dist_name ); + push @file_map, $self->_share_dir_map( $prefix, $share_dir->{dist} ); + } + + if ( $share_dir->{module} ) { + for my $mod ( keys %{ $share_dir->{module} } ) { + (my $altmod = $mod) =~ s{::}{-}g; + my $prefix = File::Spec->catdir("module", $altmod); + push @file_map, $self->_share_dir_map($prefix, $share_dir->{module}{$mod}); + } + } + + return { @file_map }; +} + +sub _share_dir_map { + my ($self, $prefix, $list) = @_; + my %files; + for my $dir ( @$list ) { + for my $f ( @{ $self->rscan_dir( $dir, sub {-f} )} ) { + $files{File::Spec->canonpath($f)} = File::Spec->catfile( + $prefix, File::Spec->abs2rel( $f, $dir ) + ); + } + } + return %files; +} + sub process_PL_files { my ($self) = @_; my $files = $self->find_PL_files; - + while (my ($file, $to) = each %$files) { unless ($self->up_to_date( $file, $to )) { $self->run_perl_script($file, [], [@$to]) or die "$file failed"; @@ -2482,7 +2778,7 @@ sub process_script_files { my $script_dir = File::Spec->catdir($self->blib, 'script'); File::Path::mkpath( $script_dir ); - + foreach my $file (keys %$files) { my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next; $self->fix_shebang_line($result) unless $self->is_vmsish; @@ -2494,7 +2790,7 @@ sub find_PL_files { my $self = shift; if (my $files = $self->{properties}{PL_files}) { # 'PL_files' is given as a Unix file spec, so we localize_file_path(). - + if (UNIVERSAL::isa($files, 'ARRAY')) { return { map {$_, [/^(.*)\.PL$/]} map $self->localize_file_path($_), @@ -2512,7 +2808,7 @@ sub find_PL_files { die "'PL_files' must be a hash reference or array reference"; } } - + return unless -d 'lib'; return { map {$_, [/^(.*)\.PL$/i ]} @{ $self->rscan_dir('lib', file_qr('\.PL$')) } }; @@ -2529,7 +2825,7 @@ sub find_script_files { # meaningless, but we preserve if present. return { map {$self->localize_file_path($_), $files->{$_}} keys %$files }; } - + # No default location for script files return {}; } @@ -2543,10 +2839,10 @@ sub find_test_files { $files = [map { -d $_ ? $self->expand_test_dir($_) : $_ } map glob, $self->split_like_shell($files)]; - + # Always given as a Unix file spec. return [ map $self->localize_file_path($_), @$files ]; - + } else { # Find all possible tests in t/ or test.pl my @tests; @@ -2558,12 +2854,12 @@ sub find_test_files { sub _find_file_by_type { my ($self, $type, $dir) = @_; - + if (my $files = $self->{properties}{"${type}_files"}) { # Always given as a Unix file spec return { map $self->localize_file_path($_), %$files }; } - + return {} unless -d $dir; return { map {$_, $_} map $self->localize_file_path($_), @@ -2584,48 +2880,48 @@ sub localize_dir_path { sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35 my ($self, @files) = @_; my $c = ref($self) ? $self->{config} : 'Module::Build::Config'; - + my ($does_shbang) = $c->get('sharpbang') =~ /^\s*\#\!/; for my $file (@files) { my $FIXIN = IO::File->new($file) or die "Can't process '$file': $!"; local $/ = "\n"; chomp(my $line = <$FIXIN>); next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. - + my ($cmd, $arg) = (split(' ', $line, 2), ''); next unless $cmd =~ /perl/i; my $interpreter = $self->{properties}{perl}; - + $self->log_verbose("Changing sharpbang in $file to $interpreter"); my $shb = ''; $shb .= $c->get('sharpbang')."$interpreter $arg\n" if $does_shbang; - + # I'm not smart enough to know the ramifications of changing the # embedded newlines here to \n, so I leave 'em in. $shb .= qq{ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' if 0; # not running under some shell } unless $self->is_windowsish; # this won't work on win32, so don't - + my $FIXOUT = IO::File->new(">$file.new") or die "Can't create new $file: $!\n"; - + # Print out the new #! line (or equivalent). local $\; undef $/; # Was localized above print $FIXOUT $shb, <$FIXIN>; close $FIXIN; close $FIXOUT; - + rename($file, "$file.bak") or die "Can't rename $file to $file.bak: $!"; - + rename("$file.new", $file) or die "Can't rename $file.new to $file: $!"; - + $self->delete_filetree("$file.bak") or $self->log_warn("Couldn't clean up $file.bak, leaving it there"); - + $self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':'; } } @@ -2634,7 +2930,7 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' sub ACTION_testpod { my $self = shift; $self->depends_on('docs'); - + eval q{use Test::Pod 0.95; 1} or die "The 'testpod' action requires Test::Pod version 0.95"; @@ -2655,7 +2951,7 @@ sub ACTION_testpodcoverage { my $self = shift; $self->depends_on('docs'); - + eval q{use Test::Pod::Coverage 1.00; 1} or die "The 'testpodcoverage' action requires ", "Test::Pod::Coverage version 1.00"; @@ -2738,9 +3034,9 @@ sub manify_bin_pods { $self->config( 'man1ext' ); my $outfile = File::Spec->catfile($mandir, $manpage); next if $self->up_to_date( $file, $outfile ); - $self->log_info("Manifying $file -> $outfile\n"); + $self->log_verbose("Manifying $file -> $outfile\n"); eval { $parser->parse_from_file( $file, $outfile ); 1 } - or $self->log_warn("Error creating '$outfile': $@\n"); + or $self->log_warn("Error creating '$outfile': $@\n"); $files->{$file} = $outfile; } } @@ -2763,9 +3059,9 @@ sub manify_lib_pods { $self->config( 'man3ext' ); my $outfile = File::Spec->catfile( $mandir, $manpage); next if $self->up_to_date( $file, $outfile ); - $self->log_info("Manifying $file -> $outfile\n"); + $self->log_verbose("Manifying $file -> $outfile\n"); eval { $parser->parse_from_file( $file, $outfile ); 1 } - or $self->log_warn("Error creating '$outfile': $@\n"); + or $self->log_warn("Error creating '$outfile': $@\n"); $files->{$file} = $outfile; } } @@ -2790,12 +3086,12 @@ sub _find_pods { sub contains_pod { my ($self, $file) = @_; return '' unless -T $file; # Only look at text files - + my $fh = IO::File->new( $file ) or die "Can't open $file: $!"; while (my $line = <$fh>) { return 1 if $line =~ /^\=(?:head|pod|item)/; } - + return ''; } @@ -2808,7 +3104,7 @@ sub ACTION_html { foreach my $type ( qw(bin lib) ) { my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"}, - exclude => + exclude => [ file_qr('\.(?:bat|com|html)$') ] ); next unless %$files; @@ -2897,9 +3193,9 @@ sub htmlify_pods { push( @opts, "--css=$path2root/" . $self->html_css) if $self->html_css; } - $self->log_info("HTMLifying $infile -> $outfile\n"); + $self->log_verbose("HTMLifying $infile -> $outfile\n"); $self->log_verbose("pod2html @opts\n"); - eval { Pod::Html::pod2html(@opts); 1 } + eval { Pod::Html::pod2html(@opts); 1 } or $self->log_warn("pod2html @opts failed: $@"); } @@ -2919,10 +3215,10 @@ sub man3page_name { my $self = shift; my ($vol, $dirs, $file) = File::Spec->splitpath( shift ); my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) ); - + # Remove known exts from the base name $file =~ s/\.p(?:od|m|l)\z//i; - + return join( $self->manpage_separator, @dirs, $file ); } @@ -2942,7 +3238,7 @@ sub ACTION_diff { my @flags = @{$self->{args}{ARGV}}; @flags = $self->split_like_shell($self->{args}{flags} || '') unless @flags; - + my $installmap = $self->install_map; delete $installmap->{read}; delete $installmap->{write}; @@ -2952,22 +3248,22 @@ sub ACTION_diff { while (my $localdir = each %$installmap) { my @localparts = File::Spec->splitdir($localdir); my $files = $self->rscan_dir($localdir, sub {-f}); - + foreach my $file (@$files) { my @parts = File::Spec->splitdir($file); @parts = @parts[@localparts .. $#parts]; # Get rid of blib/lib or similar - + my $installed = Module::Build::ModuleInfo->find_module_by_name( join('::', @parts), \@myINC ); if (not $installed) { print "Only in lib: $file\n"; next; } - + my $status = File::Compare::compare($installed, $file); next if $status == 0; # Files are the same die "Can't compare $installed and $file: $!" if $status == -1; - + if ($file =~ $text_suffix) { $self->do_system('diff', @flags, $installed, $file); } else { @@ -2985,7 +3281,7 @@ sub ACTION_install { my ($self) = @_; require ExtUtils::Install; $self->depends_on('build'); - ExtUtils::Install::install($self->install_map, !$self->quiet, 0, $self->{args}{uninst}||0); + ExtUtils::Install::install($self->install_map, $self->verbose, 0, $self->{args}{uninst}||0); } sub ACTION_fakeinstall { @@ -3005,19 +3301,74 @@ sub ACTION_fakeinstall { sub ACTION_versioninstall { my ($self) = @_; - + die "You must have only.pm 0.25 or greater installed for this operation: $@\n" unless eval { require only; 'only'->VERSION(0.25); 1 }; - + $self->depends_on('build'); - + my %onlyargs = map {exists($self->{args}{$_}) ? ($_ => $self->{args}{$_}) : ()} qw(version versionlib); only::install::install(%onlyargs); } +sub ACTION_installdeps { + my ($self) = @_; + + # XXX include feature prerequisites as optional prereqs? + + my $info = $self->_enum_prereqs; + if (! $info ) { + $self->log_info( "No prerequisites detected\n" ); + return; + } + + my $failures = $self->prereq_failures($info); + if ( ! $failures ) { + $self->log_info( "All prerequisites satisfied\n" ); + return; + } + + my @install; + while (my ($type, $prereqs) = each %$failures) { + if($type =~ m/^(?:\w+_)?requires$/) { + push(@install, keys %$prereqs); + next; + } + $self->log_info("Checking optional dependencies:\n"); + while (my ($module, $status) = each %$prereqs) { + push(@install, $module) if($self->y_n("Install $module?", 'y')); + } + } + + return unless @install; + + my ($command, @opts) = $self->split_like_shell($self->cpan_client); + + # relative command should be relative to our active Perl + # so we need to locate that command + if ( ! File::Spec->file_name_is_absolute( $command ) ) { + my @bindirs = File::Basename::dirname($self->perl); + push @bindirs, map {$self->config->{"install${_}bin"}} '','site','vendor'; + for my $d ( @bindirs ) { + my $abs_cmd = $self->find_command(File::Spec->catfile( $d, $command )); + if ( defined $abs_cmd ) { + $command = $abs_cmd; + last; + } + } + } + + if ( ! -x $command ) { + die "cpan_client '$command' is not executable\n"; + } + + $self->do_system($command, @opts, @install); +} + sub ACTION_clean { my ($self) = @_; + $self->log_info("Cleaning up build files\n"); foreach my $item (map glob($_), $self->cleanup) { $self->delete_filetree($item); } @@ -3026,11 +3377,15 @@ sub ACTION_clean { sub ACTION_realclean { my ($self) = @_; $self->depends_on('clean'); - $self->delete_filetree($self->config_dir, $self->build_script); + $self->log_info("Cleaning up configuration files\n"); + $self->delete_filetree( + $self->config_dir, $self->mymetafile, $self->build_script + ); } sub ACTION_ppd { my ($self) = @_; + require Module::Build::PPMMaker; my $ppd = Module::Build::PPMMaker->new(); my $file = $ppd->make_ppd(%{$self->{args}}, build => $self); @@ -3104,7 +3459,7 @@ sub ACTION_pardist { ); return(); } - + $self->depends_on( 'build' ); return PAR::Dist::blib_to_par( @@ -3115,11 +3470,11 @@ sub ACTION_pardist { sub ACTION_dist { my ($self) = @_; - + $self->depends_on('distdir'); - + my $dist_dir = $self->dist_dir; - + $self->make_tarball($dist_dir); $self->delete_filetree($dist_dir); } @@ -3127,6 +3482,8 @@ sub ACTION_dist { sub ACTION_distcheck { my ($self) = @_; + $self->_check_manifest_skip; + require ExtUtils::Manifest; local $^W; # ExtUtils::Manifest is not warnings clean. my ($missing, $extra) = ExtUtils::Manifest::fullcheck(); @@ -3141,6 +3498,25 @@ sub ACTION_distcheck { } } +sub _check_mymeta_skip { + my $self = shift; + my $maniskip = shift || 'MANIFEST.SKIP'; + + require ExtUtils::Manifest; + local $^W; # ExtUtils::Manifest is not warnings clean. + + # older ExtUtils::Manifest had a private _maniskip + my $skip_factory = ExtUtils::Manifest->can('maniskip') + || ExtUtils::Manifest->can('_maniskip'); + + my $mymetafile = $self->mymetafile; + # we can't check it, just add it anyway to be safe + unless ( $skip_factory && $skip_factory->($maniskip)->($mymetafile) ) { + $self->log_warn("File '$maniskip' does not include '$mymetafile'. Adding it now.\n"); + $self->_append_maniskip("^$mymetafile\$", $maniskip); + } +} + sub _add_to_manifest { my ($self, $manifest, $lines) = @_; $lines = [$lines] unless ref $lines; @@ -3153,7 +3529,7 @@ sub _add_to_manifest { my $mode = (stat $manifest)[2]; chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!"; - + my $fh = IO::File->new("< $manifest") or die "Can't read $manifest: $!"; my $last_line = (<$fh>)[-1] || "\n"; my $has_newline = $last_line =~ /\n$/; @@ -3165,7 +3541,7 @@ sub _add_to_manifest { close $fh; chmod($mode, $manifest); - $self->log_info(map "Added to $manifest: $_\n", @$lines); + $self->log_verbose(map "Added to $manifest: $_\n", @$lines); } sub _sign_dir { @@ -3175,16 +3551,16 @@ sub _sign_dir { $self->log_warn("Couldn't load Module::Signature for 'distsign' action:\n $@\n"); return; } - + # Add SIGNATURE to the MANIFEST { my $manifest = File::Spec->catfile($dir, 'MANIFEST'); die "Signing a distribution requires a MANIFEST file" unless -e $manifest; $self->_add_to_manifest($manifest, "SIGNATURE Added here by Module::Build"); } - + # Would be nice if Module::Signature took a directory argument. - + $self->_do_in_dir($dir, sub {local $Module::Signature::Quiet = 1; Module::Signature::sign()}); } @@ -3210,7 +3586,7 @@ sub ACTION_distsign { sub ACTION_skipcheck { my ($self) = @_; - + require ExtUtils::Manifest; local $^W; # ExtUtils::Manifest is not warnings clean. ExtUtils::Manifest::skipcheck(); @@ -3218,7 +3594,7 @@ sub ACTION_skipcheck { sub ACTION_distclean { my ($self) = @_; - + $self->depends_on('realclean'); $self->depends_on('distcheck'); } @@ -3235,6 +3611,11 @@ sub do_create_license { my $self = shift; $self->log_info("Creating LICENSE file\n"); + if ( ! $self->_mb_feature('license_creation') ) { + $self->_warn_mb_feature_deps('license_creation'); + die "Aborting.\n"; + } + my $l = $self->license or die "No license specified"; @@ -3243,7 +3624,7 @@ sub do_create_license { my $class = "Software::License::$key"; eval "use $class; 1" - or die "Can't load Software::License to create LICENSE file: $@"; + or die "Can't load Software::License::$key to create LICENSE file: $@"; $self->delete_filetree('LICENSE'); @@ -3270,7 +3651,9 @@ EOF return; } - if ( eval {require Pod::Readme; 1} ) { + # work around some odd Pod::Readme->new() failures in test reports by + # confirming that new() is available + if ( eval {require Pod::Readme; Pod::Readme->can('new') } ) { $self->log_info("Creating README using Pod::Readme\n"); my $parser = Pod::Readme->new; @@ -3326,29 +3709,48 @@ sub _main_docfile { } } +sub do_create_bundle_inc { + my $self = shift; + my $dist_inc = File::Spec->catdir( $self->dist_dir, 'inc' ); + require inc::latest; + inc::latest->write($dist_inc, @{$self->bundle_inc_preload}); + inc::latest->bundle_module($_, $dist_inc) for @{$self->bundle_inc}; + return 1; +} + sub ACTION_distdir { my ($self) = @_; + if ( @{$self->bundle_inc} && ! $self->_mb_feature('inc_bundling_support') ) { + $self->_warn_mb_feature_deps('inc_bundling_support'); + die "Aborting.\n"; + } + $self->depends_on('distmeta'); + # Must not include MYMETA + $self->_check_mymeta_skip('MANIFEST.SKIP'); + my $dist_files = $self->_read_manifest('MANIFEST') - or die "Can't create distdir without a MANIFEST file - run 'manifest' action first"; + or die "Can't create distdir without a MANIFEST file - run 'manifest' action first.\n"; delete $dist_files->{SIGNATURE}; # Don't copy, create a fresh one die "No files found in MANIFEST - try running 'manifest' action?\n" unless ($dist_files and keys %$dist_files); my $metafile = $self->metafile; $self->log_warn("*** Did you forget to add $metafile to the MANIFEST?\n") unless exists $dist_files->{$metafile}; - + my $dist_dir = $self->dist_dir; $self->delete_filetree($dist_dir); $self->log_info("Creating $dist_dir\n"); $self->add_to_cleanup($dist_dir); - + foreach my $file (keys %$dist_files) { my $new = $self->copy_if_modified(from => $file, to_dir => $dist_dir, verbose => 0); } - + + $self->do_create_bundle_inc if @{$self->bundle_inc}; + $self->_sign_dir($dist_dir) if $self->{properties}{sign}; } @@ -3388,8 +3790,7 @@ sub _eumanifest_has_include { my $self = shift; require ExtUtils::Manifest; - return ExtUtils::Manifest->VERSION >= 1.50 ? 1 : 0; - return 0; + return eval { ExtUtils::Manifest->VERSION(1.50); 1 }; } @@ -3436,6 +3837,19 @@ sub _slurp { } + +sub _append_maniskip { + my $self = shift; + my $skip = shift; + my $file = shift || 'MANIFEST.SKIP'; + return unless defined $skip && length $skip; + my $fh = IO::File->new(">> $file") + or die "Can't open $file: $!"; + + print $fh "$skip\n"; + $fh->close(); +} + sub _write_default_maniskip { my $self = shift; my $file = shift || 'MANIFEST.SKIP'; @@ -3446,6 +3860,8 @@ sub _write_default_maniskip { : $self->_slurp( $self->_default_maniskip ); $content .= <<'EOF'; +# Avoid configuration metadata file +^MYMETA\.$ # Avoid Module::Build generated and utility files. \bBuild$ @@ -3466,14 +3882,27 @@ EOF return; } -sub ACTION_manifest { +sub _check_manifest_skip { my ($self) = @_; my $maniskip = 'MANIFEST.SKIP'; - unless ( -e 'MANIFEST' || -e $maniskip ) { + + if ( ! -e $maniskip ) { $self->log_warn("File '$maniskip' does not exist: Creating a default '$maniskip'\n"); $self->_write_default_maniskip($maniskip); } + else { + # MYMETA must not be added to MANIFEST, so always confirm the skip + $self->_check_mymeta_skip( $maniskip ); + } + + return; +} + +sub ACTION_manifest { + my ($self) = @_; + + $self->_check_manifest_skip; require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean. local ($^W, $ExtUtils::Manifest::Quiet) = (0,1); @@ -3511,6 +3940,63 @@ sub _files_in { return @files; } +sub share_dir { + my $self = shift; + my $p = $self->{properties}; + + $p->{share_dir} = shift if @_; + + # Always coerce to proper hash form + if ( ! defined $p->{share_dir} ) { + # not set -- use default 'share' dir if exists + $p->{share_dir} = { dist => [ 'share' ] } if -d 'share'; + } + elsif ( ! ref $p->{share_dir} ) { + # scalar -- treat as a single 'dist' directory + $p->{share_dir} = { dist => [ $p->{share_dir} ] }; + } + elsif ( ref $p->{share_dir} eq 'ARRAY' ) { + # array -- treat as a list of 'dist' directories + $p->{share_dir} = { dist => $p->{share_dir} }; + } + elsif ( ref $p->{share_dir} eq 'HASH' ) { + # hash -- check structure + my $share_dir = $p->{share_dir}; + # check dist key + if ( defined $share_dir->{dist} ) { + if ( ! ref $share_dir->{dist} ) { + # scalar, so upgrade to arrayref + $share_dir->{dist} = [ $share_dir->{dist} ]; + } + elsif ( ref $share_dir->{dist} ne 'ARRAY' ) { + die "'dist' key in 'share_dir' must be scalar or arrayref"; + } + } + # check module key + if ( defined $share_dir->{module} ) { + my $mod_hash = $share_dir->{module}; + if ( ref $mod_hash eq 'HASH' ) { + for my $k ( keys %$mod_hash ) { + if ( ! ref $mod_hash->{$k} ) { + $mod_hash->{$k} = [ $mod_hash->{$k} ]; + } + elsif( ref $mod_hash->{$k} ne 'ARRAY' ) { + die "modules in 'module' key of 'share_dir' must be scalar or arrayref"; + } + } + } + else { + die "'module' key in 'share_dir' must be hashref"; + } + } + } + else { + die "'share_dir' must be hashref, arrayref or string"; + } + + return $p->{share_dir}; +} + sub script_files { my $self = shift; @@ -3529,13 +4015,13 @@ sub script_files { } my %pl_files = map { - File::Spec->canonpath( File::Spec->case_tolerant ? uc $_ : $_ ) => 1 + File::Spec->canonpath( File::Spec->case_tolerant ? uc $_ : $_ ) => 1 } keys %{ $self->PL_files || {} }; my @bin_files = $self->_files_in('bin'); my %bin_map = map { - $_ => File::Spec->canonpath( File::Spec->case_tolerant ? uc $_ : $_ ) + $_ => File::Spec->canonpath( File::Spec->case_tolerant ? uc $_ : $_ ) } @bin_files; return $_ = { map {$_ => 1} grep !$pl_files{$bin_map{$_}}, @bin_files }; @@ -3546,6 +4032,7 @@ BEGIN { *scripts = \&script_files; } my %licenses = ( perl => 'Perl_5', apache => 'Apache_2_0', + apache_1_1 => 'Apache_1_1', artistic => 'Artistic_1_0', artistic_2 => 'Artistic_2_0', lgpl => 'LGPL_2_1', @@ -3568,6 +4055,7 @@ BEGIN { *scripts = \&script_files; } my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', + apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', @@ -3615,10 +4103,10 @@ sub ACTION_distmeta { sub do_create_metafile { my $self = shift; return if $self->{wrote_metadata}; - + my $p = $self->{properties}; my $metafile = $self->metafile; - + unless ($p->{license}) { $self->log_warn("No license specified, setting license = 'unknown'\n"); $p->{license} = 'unknown'; @@ -3639,7 +4127,7 @@ sub do_create_metafile { push @INC, File::Spec->catdir($self->blib, 'lib'); } - if ( $self->write_metafile( $self->metafile, $self->generate_metadata ) ) { + if ( $self->write_metafile( $self->metafile, $self->prepare_metadata( fatal => 1 ) ) ) { $self->{wrote_metadata} = 1; $self->_add_to_manifest('MANIFEST', $metafile); } @@ -3647,42 +4135,22 @@ sub do_create_metafile { return 1; } -sub generate_metadata { - my $self = shift; - my $node = {}; - - if ($self->_mb_feature('YAML_support')) { - require YAML; - require YAML::Node; - # We use YAML::Node to get the order nice in the YAML file. - $self->prepare_metadata( $node = YAML::Node->new({}) ); - } else { - require Module::Build::YAML; - my @order_keys; - $self->prepare_metadata($node, \@order_keys); - $node->{_order} = \@order_keys; - } - return $node; -} - sub write_metafile { my $self = shift; my ($metafile, $node) = @_; + my $yaml; if ($self->_mb_feature('YAML_support')) { # XXX this is probably redundant, but stick with it - require YAML; - require YAML::Node; - delete $node->{_order}; # XXX also probably redundant, but for safety - # YAML API changed after version 0.30 - my $yaml_sub = $YAML::VERSION le '0.30' ? \&YAML::StoreFile : \&YAML::DumpFile; - $yaml_sub->( $metafile, $node ); + require YAML::Tiny; + $yaml = YAML::Tiny->new($node); } else { - # XXX probably redundant require Module::Build::YAML; - &Module::Build::YAML::DumpFile($metafile, $node); + $yaml = Module::Build::YAML->new($node); } - return 1; + my $result = $yaml->write($metafile) + or $self->log_warn( "Error writing '$metafile': " . $yaml->errstr . "\n"); + return $result; } sub normalize_version { @@ -3690,7 +4158,7 @@ sub normalize_version { if ( $version =~ /[=<>!,]/ ) { # logic, not just version # take as is without modification } - elsif ( ref $version eq 'version' || + elsif ( ref $version eq 'version' || ref $version eq 'Module::Build::Version' ) { # version objects $version = $version->is_qv ? $version->normal : $version->stringify; } @@ -3705,31 +4173,46 @@ sub normalize_version { } sub prepare_metadata { - my ($self, $node, $keys) = @_; + my ($self, %args) = @_; + my $fatal = $args{fatal} || 0; my $p = $self->{properties}; + my $node = {}; # A little helper sub my $add_node = sub { my ($name, $val) = @_; $node->{$name} = $val; - push @$keys, $name if $keys; }; foreach (qw(dist_name dist_version dist_author dist_abstract license)) { (my $name = $_) =~ s/^dist_//; $add_node->($name, $self->$_()); - die "ERROR: Missing required field '$_' for META.yml\n" - unless defined($node->{$name}) && length($node->{$name}); + unless ( defined($node->{$name}) && length($node->{$name}) ) { + my $err = "ERROR: Missing required field '$_' for metafile\n"; + if ( $fatal ) { + die $err; + } + else { + $self->log_warn($err); + } + } } - $node->{version} = $self->normalize_version($node->{version}); + $node->{version} = $self->normalize_version($node->{version}); if (defined( my $l = $self->license )) { - die "Unknown license string '$l'" - unless exists $self->valid_licenses->{ $l }; + unless ( exists $self->valid_licenses->{ $l } ) { + my $err = "Unknown license string '$l'"; + if ( $fatal ) { + die $err; + } + else { + $self->log_warn($err); + } + } if (my $key = $self->valid_licenses->{ $l }) { my $class = "Software::License::$key"; - if (eval "use $class; 1") { + if (eval "require Software::License; require $class; 1") { # S::L requires a 'holder' key $node->{resources}{license} = $class->new({holder=>"nobody"})->url; } @@ -3743,24 +4226,14 @@ sub prepare_metadata { # copy prereq data structures so we can modify them before writing to META my %prereq_types; for my $type ( 'configure_requires', @{$self->prereq_action_types} ) { - if (exists $p->{$type}) { + if (exists $p->{$type}) { for my $mod ( keys %{ $p->{$type} } ) { - $prereq_types{$type}{$mod} = + $prereq_types{$type}{$mod} = $self->normalize_version($p->{$type}{$mod}); } } } - # add current Module::Build to configure_requires if there - # isn't one already specified (but not ourself, so we're not circular) - if ( $self->dist_name ne 'Module-Build' - && $self->auto_configure_requires - && ! exists $prereq_types{'configure_requires'}{'Module::Build'} - ) { - (my $ver = $VERSION) =~ s/^(\d+\.\d\d).*$/$1/; # last major release only - $prereq_types{configure_requires}{'Module::Build'} = $ver; - } - for my $t ( keys %prereq_types ) { $add_node->($t, $prereq_types{$t}); } @@ -3771,7 +4244,7 @@ sub prepare_metadata { my $pkgs = eval { $self->find_dist_packages }; if ($@) { $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" . - "Nothing to enter for 'provides' field in META.yml\n"); + "Nothing to enter for 'provides' field in metafile.\n"); } else { $node->{provides} = $pkgs if %$pkgs; } @@ -3782,7 +4255,7 @@ sub prepare_metadata { $add_node->('generated_by', "Module::Build version $Module::Build::VERSION"); - $add_node->('meta-spec', + $add_node->('meta-spec', {version => '1.4', url => 'http://module-build.sourceforge.net/META-spec-v1.4.html', }); @@ -3815,44 +4288,52 @@ sub find_dist_packages { # private stock. my $manifest = $self->_read_manifest('MANIFEST') - or die "Can't find dist packages without a MANIFEST file - run 'manifest' action first"; + or die "Can't find dist packages without a MANIFEST file\nRun 'Build manifest' to generate one\n"; # Localize my %dist_files = map { $self->localize_file_path($_) => $_ } keys %$manifest; - my @pm_files = grep {exists $dist_files{$_}} keys %{ $self->find_pm_files }; + my @pm_files = grep { $_ !~ m{^t} } # skip things in t/ + grep {exists $dist_files{$_}} + keys %{ $self->find_pm_files }; + + return $self->find_packages_in_files(\@pm_files, \%dist_files); +} + +sub find_packages_in_files { + my ($self, $file_list, $filename_map) = @_; # First, we enumerate all packages & versions, # separating into primary & alternative candidates my( %prime, %alt ); - foreach my $file (@pm_files) { - next if $dist_files{$file} =~ m{^t/}; # Skip things in t/ - - my @path = split( /\//, $dist_files{$file} ); + foreach my $file (@{$file_list}) { + my $mapped_filename = $filename_map->{$file}; + my @path = split( /\//, $mapped_filename ); (my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//; my $pm_info = Module::Build::ModuleInfo->new_from_file( $file ); foreach my $package ( $pm_info->packages_inside ) { next if $package eq 'main'; # main can appear numerous times, ignore + next if $package eq 'DB'; # special debugging package, ignore next if grep /^_/, split( /::/, $package ); # private package, ignore my $version = $pm_info->version( $package ); if ( $package eq $prime_package ) { - if ( exists( $prime{$package} ) ) { - # M::B::ModuleInfo will handle this conflict - die "Unexpected conflict in '$package'; multiple versions found.\n"; - } else { - $prime{$package}{file} = $dist_files{$file}; + if ( exists( $prime{$package} ) ) { + # M::B::ModuleInfo will handle this conflict + die "Unexpected conflict in '$package'; multiple versions found.\n"; + } else { + $prime{$package}{file} = $mapped_filename; $prime{$package}{version} = $version if defined( $version ); } } else { - push( @{$alt{$package}}, { - file => $dist_files{$file}, - version => $version, - } ); + push( @{$alt{$package}}, { + file => $mapped_filename, + version => $version, + } ); } } } @@ -3972,24 +4453,29 @@ sub _resolve_module_versions { sub make_tarball { my ($self, $dir, $file) = @_; $file ||= $dir; - + $self->log_info("Creating $file.tar.gz\n"); - + if ($self->{args}{tar}) { my $tar_flags = $self->verbose ? 'cvf' : 'cf'; $self->do_system($self->split_like_shell($self->{args}{tar}), $tar_flags, "$file.tar", $dir); $self->do_system($self->split_like_shell($self->{args}{gzip}), "$file.tar") if $self->{args}{gzip}; } else { - eval { require Archive::Tar && Archive::Tar->VERSION(1.08); 1 } - or die "You must install Archive::Tar to make a distribution tarball\n". + eval { require Archive::Tar && Archive::Tar->VERSION(1.09); 1 } + or die "You must install Archive::Tar 1.09+ to make a distribution tarball\n". "or specify a binary tar program with the '--tar' option.\n". "See the documentation for the 'dist' action.\n"; + my $files = $self->rscan_dir($dir); + # Archive::Tar versions >= 1.09 use the following to enable a compatibility # hack so that the resulting archive is compatible with older clients. - $Archive::Tar::DO_NOT_USE_PREFIX = 0; + # If no file path is 100 chars or longer, we disable the prefix field + # for maximum compatibility. If there are any long file paths then we + # need the prefix field after all. + $Archive::Tar::DO_NOT_USE_PREFIX = + (grep { length($_) >= 100 } @$files) ? 0 : 1; - my $files = $self->rscan_dir($dir); my $tar = Archive::Tar->new; $tar->add_files(@$files); for my $f ($tar->get_files) { @@ -4055,7 +4541,7 @@ sub original_prefix { # or original_prefix('lib' => $value); my ($self, $key, $value) = @_; # update property before merging with defaults - if ( @_ == 3 && defined $key) { + if ( @_ == 3 && defined $key) { # $value can be undef; will mask default $self->{properties}{original_prefix}{$key} = $value; } @@ -4263,7 +4749,7 @@ sub install_map { } } } - + $map{read} = ''; # To keep ExtUtils::Install quiet return \%map; @@ -4284,7 +4770,7 @@ sub rscan_dir { !ref($pattern) || (ref $pattern eq 'Regexp') ? sub {push @result, $File::Find::name if /$pattern/} : ref($pattern) eq 'CODE' ? sub {push @result, $File::Find::name if $pattern->()} : die "Unknown pattern type"; - + File::Find::find({wanted => $subr, no_chdir => 1}, $dir); return \@result; } @@ -4294,7 +4780,7 @@ sub delete_filetree { my $deleted = 0; foreach (@_) { next unless -e $_; - $self->log_info("Deleting $_\n"); + $self->log_verbose("Deleting $_\n"); File::Path::rmtree($_, 0, 0); die "Couldn't remove '$_': $!\n" if -e $_; $deleted++; @@ -4315,8 +4801,6 @@ sub cbuilder { my $self = shift; my $s = $self->{stash}; return $s->{_cbuilder} if $s->{_cbuilder}; - die "Module::Build is not configured with C_support" - unless $self->_mb_feature('C_support'); require ExtUtils::CBuilder; return $s->{_cbuilder} = ExtUtils::CBuilder->new( @@ -4327,21 +4811,25 @@ sub cbuilder { sub have_c_compiler { my ($self) = @_; - + my $p = $self->{properties}; - return $p->{have_compiler} if defined $p->{have_compiler}; - + return $p->{_have_c_compiler} if defined $p->{_have_c_compiler}; + $self->log_verbose("Checking if compiler tools configured... "); my $b = eval { $self->cbuilder }; - my $have = $b && $b->have_compiler; + my $have = $b && eval { $b->have_compiler }; $self->log_verbose($have ? "ok.\n" : "failed.\n"); - return $p->{have_compiler} = $have; + return $p->{_have_c_compiler} = $have; } sub compile_c { my ($self, $file, %args) = @_; - my $b = $self->cbuilder; + if ( ! $self->have_c_compiler ) { + die "Error: no compiler detected to compile '$file'. Aborting\n"; + } + + my $b = $self->cbuilder; my $obj_file = $b->object_file($file); $self->add_to_cleanup($obj_file); return $obj_file if $self->up_to_date($file, $obj_file); @@ -4381,11 +4869,11 @@ sub link_c { sub compile_xs { my ($self, $file, %args) = @_; - - $self->log_info("$file -> $args{outfile}\n"); + + $self->log_verbose("$file -> $args{outfile}\n"); if (eval {require ExtUtils::ParseXS; 1}) { - + ExtUtils::ParseXS::process_file( filename => $file, prototypes => 0, @@ -4393,26 +4881,26 @@ sub compile_xs { ); } else { # Ok, I give up. Just use backticks. - + my $xsubpp = Module::Build::ModuleInfo->find_module_by_name('ExtUtils::xsubpp') or die "Can't find ExtUtils::xsubpp in INC (@INC)"; - + my @typemaps; push @typemaps, Module::Build::ModuleInfo->find_module_by_name( 'ExtUtils::typemap', \@INC ); my $lib_typemap = Module::Build::ModuleInfo->find_module_by_name( - 'typemap', [File::Basename::dirname($file)] + 'typemap', [File::Basename::dirname($file), File::Spec->rel2abs('.')] ); push @typemaps, $lib_typemap if $lib_typemap; @typemaps = map {+'-typemap', $_} @typemaps; my $cf = $self->{config}; my $perl = $self->{properties}{perl}; - + my @command = ($perl, "-I".$cf->get('installarchlib'), "-I".$cf->get('installprivlib'), $xsubpp, '-noprototypes', @typemaps, $file); - + $self->log_info("@command\n"); my $fh = IO::File->new("> $args{outfile}") or die "Couldn't write $args{outfile}: $!"; print {$fh} $self->_backticks(@command); @@ -4422,12 +4910,12 @@ sub compile_xs { sub split_like_shell { my ($self, $string) = @_; - + return () unless defined($string); return @$string if UNIVERSAL::isa($string, 'ARRAY'); $string =~ s/^\s+|\s+$//g; return () unless length($string); - + return Text::ParseWords::shellwords($string); } @@ -4553,12 +5041,12 @@ sub process_xs { sub do_system { my ($self, @cmd) = @_; - $self->log_info("@cmd\n"); + $self->log_verbose("@cmd\n"); # Some systems proliferate huge PERL5LIBs, try to ameliorate: my %seen; my $sep = $self->config('path_sep'); - local $ENV{PERL5LIB} = + local $ENV{PERL5LIB} = ( !exists($ENV{PERL5LIB}) ? '' : length($ENV{PERL5LIB}) < 500 ? $ENV{PERL5LIB} @@ -4587,8 +5075,8 @@ sub copy_if_modified { unless (defined $file and length $file) { die "No 'from' parameter given to copy_if_modified"; } - - # makes no sense to replicate an absolute path, so assume flatten + + # makes no sense to replicate an absolute path, so assume flatten $args{flatten} = 1 if File::Spec->file_name_is_absolute( $file ); my $to_path; @@ -4601,7 +5089,7 @@ sub copy_if_modified { } else { die "No 'to' or 'to_dir' parameter given to copy_if_modified"; } - + return if $self->up_to_date($file, $to_path); # Already fresh { @@ -4611,9 +5099,9 @@ sub copy_if_modified { # Create parent directories File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777)); - - $self->log_info("Copying $file -> $to_path\n") if $args{verbose}; - + + $self->log_verbose("Copying $file -> $to_path\n"); + if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite chmod 0666, $to_path; File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!"; @@ -4644,7 +5132,7 @@ sub up_to_date { } $most_recent_source = -M _ if -M _ < $most_recent_source; } - + foreach my $derived (@$derived) { return 0 if -M $derived > $most_recent_source; } @@ -4655,21 +5143,21 @@ sub dir_contains { my ($self, $first, $second) = @_; # File::Spec doesn't have an easy way to check whether one directory # is inside another, unfortunately. - + ($first, $second) = map File::Spec->canonpath($_), ($first, $second); my @first_dirs = File::Spec->splitdir($first); my @second_dirs = File::Spec->splitdir($second); return 0 if @second_dirs < @first_dirs; - + my $is_same = ( File::Spec->case_tolerant ? sub {lc(shift()) eq lc(shift())} : sub {shift() eq shift()} ); - + while (@first_dirs) { return 0 unless $is_same->(shift @first_dirs, shift @second_dirs); } - + return 1; } diff --git a/cpan/Module-Build/lib/Module/Build/Bundling.pod b/cpan/Module-Build/lib/Module/Build/Bundling.pod new file mode 100644 index 0000000000..5e7b9f9807 --- /dev/null +++ b/cpan/Module-Build/lib/Module/Build/Bundling.pod @@ -0,0 +1,147 @@ +=head1 NAME + +Module::Build::Bundling - How to bundle Module::Build with a distribution + +=head1 SYNOPSIS + + # Build.PL + use inc::latest 'Module::Build'; + + Module::Build->new( + module_name => 'Foo::Bar', + license => 'perl', + )->create_build_script; + +=head1 DESCRIPTION + +B<WARNING -- THIS IS AN EXPERIMENTAL FEATURE> + +In order to install a distribution using Module::Build, users must +have Module::Build available on their systems. There are two ways +to do this. The first way is to include Module::Build in the +C<configure_requires> metadata field. This field is supported by +recent versions L<CPAN> and L<CPANPLUS> and is a standard feature +in the Perl core as of Perl 5.10.1. Module::Build now adds itself +to C<configure_requires> by default. + +The second way supports older Perls that have not upgraded CPAN or +CPANPLUS and involves bundling an entire copy of Module::Build +into the distribution's C<inc/> directory. This is the same approach +used by L<Module::Install>, a modern wrapper around ExtUtils::MakeMaker +for Makefile.PL based distributions. + +The "trick" to making this work for Module::Build is making sure the +highest version Module::Build is used, whether this is in C<inc/> or +already installed on the user's system. This ensures that all necessary +features are available as well as any new bug fixes. This is done using +the new L<inc::latest> module. + +A "normal" Build.PL looks like this (with only the minimum required +fields): + + use Module::Build; + + Module::Build->new( + module_name => 'Foo::Bar', + license => 'perl', + )->create_build_script; + +A "bundling" Build.PL replaces the initial "use" line with a nearly +transparent replacement: + + use inc::latest 'Module::Build'; + + Module::Build->new( + module_name => 'Foo::Bar', + license => 'perl', + )->create_build_script; + +For I<authors>, when "Build dist" is run, Module::Build will be +automatically bundled into C<inc> according to the rules for +L<inc::latest>. + +For I<users>, inc::latest will load the latest Module::Build, whether +installed or bundled in C<inc/>. + +=head1 BUNDLING OTHER CONFIGURATION DEPENDENCIES + +The same approach works for other configuration dependencies -- modules +that I<must> be available for Build.PL to run. All other dependencies can +be specified as usual in the Build.PL and CPAN or CPANPLUS will install +them after Build.PL finishes. + +For example, to bundle the L<Devel::AssertOS::Unix> module (which ensures a +"Unix-like" operating system), one could do this: + + use inc::latest 'Devel::AssertOS::Unix'; + use inc::latest 'Module::Build'; + + Module::Build->new( + module_name => 'Foo::Bar', + license => 'perl', + )->create_build_script; + +The C<inc::latest> module creates bundled directories based on the packlist +file of an installed distribution. Even though C<inc::latest> takes module +name arguments, it is better to think of it as bundling and making +available entire I<distributions>. When a module is loaded through +C<inc::latest>, it looks in all bundled distributions in C<inc/> for a +newer module than can be found in the existing C<@INC> array. + +Thus, the module-name provided should usually be the "top-level" module +name of a distribution, though this is not strictly required. For example, +L<Module::Build> has a number of heuristics to map module names to +packlists, allowing users to do things like this: + + use inc::latest 'Devel::AssertOS::Unix'; + +even though Devel::AssertOS::Unix is contained within the Devel-CheckOS +distribution. + +At the current time, packlists are required. Thus, bundling dual-core +modules, I<including Module::Build>, may require a 'forced install' over +versions in the latest version of perl in order to create the necessary +packlist for bundling. This limitation will hopefully be addressed in a +future version of Module::Build. + +=head2 WARNING -- How to Manage Dependency Chains + +Before bundling a distribution you must ensure that all prerequisites are +also bundled and load in the correct order. For Module::Build itself, this +should not be necessary, but it is necessary for any other distribution. +(A future release of Module::Build will hopefully address this deficiency.) + +For example, if you need C<Wibble>, but C<Wibble> depends on C<Wobble>, +your Build.PL might look like this: + + use inc::latest 'Wobble'; + use inc::latest 'Wibble'; + use inc::latest 'Module::Build'; + + Module::Build->new( + module_name => 'Foo::Bar', + license => 'perl', + )->create_build_script; + +Authors are strongly suggested to limit the bundling of additional +dependencies if at all possible and to carefully test their distribution +tarballs on older versions of Perl before uploading to CPAN. + +=head1 AUTHOR + +David Golden <dagolden@cpan.org> + +Development questions, bug reports, and patches should be sent to the +Module-Build mailing list at <module-build@perl.org>. + +Bug reports are also welcome at +<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build>. + +=head1 SEE ALSO + +perl(1), L<inc::latest>, L<Module::Build>(3), L<Module::Build::API>(3), +L<Module::Build::Cookbook>(3), + +=cut + +# vim: tw=75 diff --git a/cpan/Module-Build/lib/Module/Build/Compat.pm b/cpan/Module-Build/lib/Module/Build/Compat.pm index dfe75d5e1a..c8a3670333 100644 --- a/cpan/Module-Build/lib/Module/Build/Compat.pm +++ b/cpan/Module-Build/lib/Module/Build/Compat.pm @@ -2,7 +2,7 @@ package Module::Build::Compat; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; use File::Basename (); use File::Spec; @@ -64,13 +64,50 @@ my %macro_to_build = %makefile_to_build; # "LIB=foo make" is not the same as "perl Makefile.PL LIB=foo" delete $macro_to_build{LIB}; +sub _simple_prereq { + return $_[0] =~ /^[0-9_]+\.?[0-9_]*$/; # crudly, a decimal literal +} + +sub _merge_prereq { + my ($req, $breq) = @_; + $req ||= {}; + $breq ||= {}; + # validate formats + for my $p ( $req, $breq ) { + for my $k (keys %$p) { + die "Prereq '$p->{$k}' for '$k' is not supported by Module::Build::Compat\n" + unless _simple_prereq($p->{$k}); + } + } + # merge + my $merge = { %$req }; + for my $k ( keys %$breq ) { + my $v1 = $merge->{$k} || 0; + my $v2 = $breq->{$k}; + $merge->{$k} = $v1 > $v2 ? $v1 : $v2; + } + return %$merge; +} + + sub create_makefile_pl { my ($package, $type, $build, %args) = @_; die "Don't know how to build Makefile.PL of type '$type'" unless $type =~ /^(small|passthrough|traditional)$/; + if ($type eq 'passthrough') { + $build->log_warn(<<"HERE"); + +IMPORTANT NOTE: The '$type' style of Makefile.PL is deprecated and +may be removed in a future version of Module::Build in favor of the +'configure_requires' property. See Module::Build::Compat +documentation for details. + +HERE + } + my $fh; if ($args{fh}) { $fh = $args{fh}; @@ -176,7 +213,7 @@ EOF ); %MM_Args = (%name, %version); - %prereq = ( %{$build->requires}, %{$build->build_requires} ); + %prereq = _merge_prereq( $build->requires, $build->build_requires ); %prereq = map {$_, $prereq{$_}} sort keys %prereq; delete $prereq{perl}; @@ -189,7 +226,7 @@ EOF $MM_Args{PL_FILES} = $build->PL_files || {}; if ($build->recursive_test_files) { - $MM_Args{TESTS} = join q{ }, $package->_test_globs($build); + $MM_Args{test} = { TESTS => join q{ }, $package->_test_globs($build) }; } local $Data::Dumper::Terse = 1; @@ -363,15 +400,13 @@ sub fake_prereqs { my $fh = IO::File->new("< $file") or die "Can't read $file: $!"; my $prereqs = eval do {local $/; <$fh>}; close $fh; - + + my %merged = _merge_prereq( $prereqs->{requires}, $prereqs->{build_requires} ); my @prereq; - foreach my $section (qw/build_requires requires/) { - foreach (keys %{$prereqs->{$section}}) { - next if $_ eq 'perl'; - push @prereq, "$_=>q[$prereqs->{$section}{$_}]"; - } + foreach (sort keys %merged) { + next if $_ eq 'perl'; + push @prereq, "$_=>q[$merged{$_}]"; } - return unless @prereq; return "# PREREQ_PM => { " . join(", ", @prereq) . " }\n\n"; } @@ -414,7 +449,7 @@ Module::Build::Compat - Compatibility with ExtUtils::MakeMaker my $build = Module::Build->new ( module_name => 'Foo::Bar', license => 'perl', - create_makefile_pl => 'passthrough' ); + create_makefile_pl => 'traditional' ); ... @@ -448,6 +483,18 @@ The currently supported styles are: =over 4 +=item traditional + +A F<Makefile.PL> will be created in the "traditional" style, i.e. it will +use C<ExtUtils::MakeMaker> and won't rely on C<Module::Build> at all. +In order to create the F<Makefile.PL>, we'll include the C<requires> and +C<build_requires> dependencies as the C<PREREQ_PM> parameter. + +You don't want to use this style if during the C<perl Build.PL> stage +you ask the user questions, or do some auto-sensing about the user's +environment, or if you subclass C<Module::Build> to do some +customization, because the vanilla F<Makefile.PL> won't do any of that. + =item small A small F<Makefile.PL> will be created that passes all functionality @@ -455,24 +502,22 @@ through to the F<Build.PL> script in the same directory. The user must already have C<Module::Build> installed in order to use this, or else they'll get a module-not-found error. -=item passthrough +=item passthrough (DEPRECATED) This is just like the C<small> option above, but if C<Module::Build> is not already installed on the user's system, the script will offer to use C<CPAN.pm> to download it and install it before continuing with the build. -=item traditional +This option has been deprecated and may be removed in a future version +of Module::Build. Modern CPAN.pm and CPANPLUS will recognize the +C<configure_requires> metadata property and install Module::Build before +running Build.PL if Module::Build is listed and Module::Build now +adds itself to configure_requires by default. -A F<Makefile.PL> will be created in the "traditional" style, i.e. it will -use C<ExtUtils::MakeMaker> and won't rely on C<Module::Build> at all. -In order to create the F<Makefile.PL>, we'll include the C<requires> and -C<build_requires> dependencies as the C<PREREQ_PM> parameter. - -You don't want to use this style if during the C<perl Build.PL> stage -you ask the user questions, or do some auto-sensing about the user's -environment, or if you subclass C<Module::Build> to do some -customization, because the vanilla F<Makefile.PL> won't do any of that. +Perl 5.10.1 includes C<configure_requires> support. In the future, when +C<configure_requires> support is deemed sufficiently widespread, the +C<passthrough> style will be removed. =back diff --git a/cpan/Module-Build/lib/Module/Build/Config.pm b/cpan/Module-Build/lib/Module/Build/Config.pm index de8b44d092..49b5881dc1 100644 --- a/cpan/Module-Build/lib/Module/Build/Config.pm +++ b/cpan/Module-Build/lib/Module/Build/Config.pm @@ -2,7 +2,7 @@ package Module::Build::Config; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Config; diff --git a/lib/Module/Build/ConfigData.pm b/cpan/Module-Build/lib/Module/Build/ConfigData.pm index 76956bcbc2..83c88922dc 100644 --- a/lib/Module/Build/ConfigData.pm +++ b/cpan/Module-Build/lib/Module/Build/ConfigData.pm @@ -51,18 +51,18 @@ sub write { sub feature { my ($package, $key) = @_; return $features->{$key} if exists $features->{$key}; - + my $info = $auto_features->{$key} or return 0; - + # Under perl 5.005, each(%$foo) isn't working correctly when $foo # was reanimated with Data::Dumper and eval(). Not sure why, but # copying to a new hash seems to solve it. my %info = %$info; - + require Module::Build; # XXX should get rid of this while (my ($type, $prereqs) = each %info) { next if $type eq 'description' || $type eq 'recommends'; - + my %p = %$prereqs; # Ditto here. while (my ($modname, $spec) = each %p) { my $status = Module::Build->check_installed_status($modname, $spec); @@ -78,16 +78,15 @@ sub feature { Module::Build::ConfigData - Configuration for Module::Build - =head1 SYNOPSIS use Module::Build::ConfigData; $value = Module::Build::ConfigData->config('foo'); $value = Module::Build::ConfigData->feature('bar'); - + @names = Module::Build::ConfigData->config_names; @names = Module::Build::ConfigData->feature_names; - + Module::Build::ConfigData->set_config(foo => $new_value); Module::Build::ConfigData->set_feature(bar => $new_value); Module::Build::ConfigData->write; # Save changes @@ -163,17 +162,30 @@ authorship claim or copyright claim to the contents of C<Module::Build::ConfigDa =cut -__DATA__ +__DATA__ do{ my $x = [ {}, {}, { + 'license_creation' => { + 'requires' => { + 'Software::License' => 0 + }, + 'description' => 'Create licenses automatically in distributions' + }, + 'inc_bundling_support' => { + 'requires' => { + 'ExtUtils::Installed' => '1.999', + 'ExtUtils::Install' => '1.54' + }, + 'description' => 'Bundle Module::Build in inc/' + }, 'YAML_support' => { 'requires' => { - 'YAML' => ' >= 0.35, != 0.49_01 ' + 'YAML::Tiny' => '1.38' }, - 'description' => 'Use YAML.pm to write META.yml files' + 'description' => 'Use YAML::Tiny to write META.yml files' }, 'manpage_support' => { 'requires' => { @@ -181,15 +193,22 @@ do{ my $x = [ }, 'description' => 'Create Unix man pages' }, - 'C_support' => { - 'requires' => { - 'ExtUtils::CBuilder' => '0.15' - }, - 'recommends' => { - 'ExtUtils::ParseXS' => '1.02' + 'PPM_support' => { + 'requires' => { + 'IO::File' => '1.13' }, - 'description' => 'Compile/link C & XS code' - }, + 'description' => 'Generate PPM files for distributions' + }, + 'dist_authoring' => { + 'requires' => { + 'Archive::Tar' => '1.09' + }, + 'recommends' => { + 'Module::Signature' => '0.21', + 'Pod::Readme' => '0.04' + }, + 'description' => 'Create new distributions' + }, 'HTML_support' => { 'requires' => { 'Pod::Html' => 0 @@ -198,4 +217,4 @@ do{ my $x = [ } } ]; -$x; }
\ No newline at end of file +$x; } diff --git a/cpan/Module-Build/lib/Module/Build/Cookbook.pm b/cpan/Module-Build/lib/Module/Build/Cookbook.pm index 82c8e01d67..a5182aeaf5 100644 --- a/cpan/Module-Build/lib/Module/Build/Cookbook.pm +++ b/cpan/Module-Build/lib/Module/Build/Cookbook.pm @@ -1,7 +1,7 @@ package Module::Build::Cookbook; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; =head1 NAME diff --git a/cpan/Module-Build/lib/Module/Build/Dumper.pm b/cpan/Module-Build/lib/Module/Build/Dumper.pm index 1cd8cd0e16..12d63d581a 100644 --- a/cpan/Module-Build/lib/Module/Build/Dumper.pm +++ b/cpan/Module-Build/lib/Module/Build/Dumper.pm @@ -1,7 +1,7 @@ package Module::Build::Dumper; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; # This is just a split-out of a wrapper function to do Data::Dumper # stuff "the right way". See: diff --git a/cpan/Module-Build/lib/Module/Build/ModuleInfo.pm b/cpan/Module-Build/lib/Module/Build/ModuleInfo.pm index 4de09b4c68..90e4bb43c2 100644 --- a/cpan/Module-Build/lib/Module/Build/ModuleInfo.pm +++ b/cpan/Module-Build/lib/Module/Build/ModuleInfo.pm @@ -8,13 +8,14 @@ package Module::Build::ModuleInfo; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use File::Spec; use IO::File; use Module::Build::Version; +my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal my $PKG_REGEXP = qr{ # match a package declaration ^[\s\{;]* # intro chars on a line @@ -22,6 +23,8 @@ my $PKG_REGEXP = qr{ # match a package declaration \s+ # whitespace ([\w:]+) # a package name \s* # optional whitespace + ($V_NUM_REGEXP)? # optional version number + \s* # optional whitesapce ; # semicolon line terminator }x; @@ -221,10 +224,10 @@ sub _parse_fh { $self->_parse_version_expression( $line ); if ( $line =~ $PKG_REGEXP ) { - $pkg = $1; - push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs ); - $vers{$pkg} = undef unless exists( $vers{$pkg} ); - $need_vers = 1; + $pkg = $1; + push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs ); + $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} ); + $need_vers = defined $2 ? 0 : 1; # VERSION defined with full package spec, i.e. $Module::VERSION } elsif ( $vers_fullname && $vers_pkg ) { @@ -323,11 +326,22 @@ sub _evaluate_version_line { (ref($vsub) eq 'CODE') or die "failed to build version sub for $self->{filename}"; my $result = eval { $vsub->() }; + die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" + if $@; - die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@; + # Activestate apparently creates custom versions like '1.23_45_01', which + # cause M::B::Version to think it's an invalid alpha. So check for that + # and strip them + my $num_dots = () = $result =~ m{\.}g; + my $num_unders = () = $result =~ m{_}g; + if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) { + $result =~ s{_}{}g; + } # Bless it into our own version class - $result = Module::Build::Version->new($result); + eval { $result = Module::Build::Version->new($result) }; + die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" + if $@; return $result; } diff --git a/cpan/Module-Build/lib/Module/Build/Notes.pm b/cpan/Module-Build/lib/Module/Build/Notes.pm index fe98419759..9b48f4c077 100644 --- a/cpan/Module-Build/lib/Module/Build/Notes.pm +++ b/cpan/Module-Build/lib/Module/Build/Notes.pm @@ -4,7 +4,7 @@ package Module::Build::Notes; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Data::Dumper; use IO::File; @@ -111,13 +111,61 @@ sub _dump { print {$fh} Module::Build::Dumper->_data_dump($data); } +my $orig_template = do { local $/; <DATA> }; +close DATA; + sub write_config_data { my ($self, %args) = @_; + my $template = $orig_template; + $template =~ s/NOTES_NAME/$args{config_module}/g; + $template =~ s/MODULE_NAME/$args{module}/g; + $template =~ s/=begin private\n//; + $template =~ s/=end private/=cut/; + + # strip out private POD markers we use to keep pod from being + # recognized for *this* source file + $template =~ s{$_\n}{} for '=begin private', '=end private'; + my $fh = IO::File->new("> $args{file}") or die "Can't create '$args{file}': $!"; + print {$fh} $template; + print {$fh} "\n__DATA__\n"; + print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]); + +} + +1; + + +=head1 NAME + +Module::Build::Notes - Create persistent distribution configuration modules + +=head1 DESCRIPTION + +This module is used internally by Module::Build to create persistent +configuration files that can be installed with a distribution. See +L<Module::Build::ConfigData> for an example. + +=head1 AUTHOR + +Ken Williams <kwilliams@cpan.org> - printf $fh <<'EOF', $args{config_module}; -package %s; +=head1 COPYRIGHT + +Copyright (c) 2001-2006 Ken Williams. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +perl(1), L<Module::Build>(3) + +=cut + +__DATA__ +package NOTES_NAME; use strict; my $arrayref = eval do {local $/; <DATA>} or die "Couldn't load ConfigData data: $@"; @@ -129,14 +177,14 @@ sub config { $config->{$_[1]} } sub set_config { $config->{$_[1]} = $_[2] } sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0 -sub auto_feature_names { grep !exists $features->{$_}, keys %%$auto_features } +sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features } sub feature_names { - my @features = (keys %%$features, auto_feature_names()); + my @features = (keys %$features, auto_feature_names()); @features; } -sub config_names { keys %%$config } +sub config_names { keys %$config } sub write { my $me = __FILE__; @@ -173,17 +221,17 @@ sub feature { my $info = $auto_features->{$key} or return 0; - # Under perl 5.005, each(%%$foo) isn't working correctly when $foo + # Under perl 5.005, each(%$foo) isn't working correctly when $foo # was reanimated with Data::Dumper and eval(). Not sure why, but # copying to a new hash seems to solve it. - my %%info = %%$info; + my %info = %$info; require Module::Build; # XXX should get rid of this - while (my ($type, $prereqs) = each %%info) { + while (my ($type, $prereqs) = each %info) { next if $type eq 'description' || $type eq 'recommends'; - my %%p = %%$prereqs; # Ditto here. - while (my ($modname, $spec) = each %%p) { + my %p = %$prereqs; # Ditto here. + while (my ($modname, $spec) = each %p) { my $status = Module::Build->check_installed_status($modname, $spec); if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; } if ( ! eval "require $modname; 1" ) { return 0; } @@ -192,36 +240,32 @@ sub feature { return 1; } -EOF - - my ($module_name, $notes_name) = ($args{module}, $args{config_module}); - printf $fh <<"EOF", $notes_name, $module_name; +=begin private =head1 NAME -$notes_name - Configuration for $module_name - +NOTES_NAME - Configuration for MODULE_NAME =head1 SYNOPSIS - use $notes_name; - \$value = $notes_name->config('foo'); - \$value = $notes_name->feature('bar'); + use NOTES_NAME; + $value = NOTES_NAME->config('foo'); + $value = NOTES_NAME->feature('bar'); - \@names = $notes_name->config_names; - \@names = $notes_name->feature_names; + @names = NOTES_NAME->config_names; + @names = NOTES_NAME->feature_names; - $notes_name->set_config(foo => \$new_value); - $notes_name->set_feature(bar => \$new_value); - $notes_name->write; # Save changes + NOTES_NAME->set_config(foo => $new_value); + NOTES_NAME->set_feature(bar => $new_value); + NOTES_NAME->write; # Save changes =head1 DESCRIPTION -This module holds the configuration data for the C<$module_name> +This module holds the configuration data for the C<MODULE_NAME> module. It also provides a programmatic interface for getting or setting that configuration data. Note that in order to actually make -changes, you'll have to have write access to the C<$notes_name> +changes, you'll have to have write access to the C<NOTES_NAME> module, and you should attempt to understand the repercussions of your actions. @@ -230,17 +274,17 @@ actions. =over 4 -=item config(\$name) +=item config($name) Given a string argument, returns the value of the configuration item by that name, or C<undef> if no such item exists. -=item feature(\$name) +=item feature($name) Given a string argument, returns the value of the feature by that name, or C<undef> if no such feature exists. -=item set_config(\$name, \$value) +=item set_config($name, $value) Sets the configuration item with the given name to the given value. The value may be any Perl scalar that will serialize correctly using @@ -248,7 +292,7 @@ C<Data::Dumper>. This includes references, objects (usually), and complex data structures. It probably does not include transient things like filehandles or sockets. -=item set_feature(\$name, \$value) +=item set_feature($name, $value) Sets the feature with the given name to the given boolean value. The value will be converted to 0 or 1 automatically. @@ -256,12 +300,12 @@ value will be converted to 0 or 1 automatically. =item config_names() Returns a list of all the names of config items currently defined in -C<$notes_name>, or in scalar context the number of items. +C<NOTES_NAME>, or in scalar context the number of items. =item feature_names() Returns a list of all the names of features currently defined in -C<$notes_name>, or in scalar context the number of features. +C<NOTES_NAME>, or in scalar context the number of features. =item auto_feature_names() @@ -273,24 +317,16 @@ a fixed value. =item write() Commits any changes from C<set_config()> and C<set_feature()> to disk. -Requires write access to the C<$notes_name> module. +Requires write access to the C<NOTES_NAME> module. =back =head1 AUTHOR -C<$notes_name> was automatically created using C<Module::Build>. +C<NOTES_NAME> was automatically created using C<Module::Build>. C<Module::Build> was written by Ken Williams, but he holds no -authorship claim or copyright claim to the contents of C<$notes_name>. - -=cut - -__DATA__ +authorship claim or copyright claim to the contents of C<NOTES_NAME>. -EOF +=end private - print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]); -} - -1; diff --git a/cpan/Module-Build/lib/Module/Build/PPMMaker.pm b/cpan/Module-Build/lib/Module/Build/PPMMaker.pm index 35b5a75317..8567626cdd 100644 --- a/cpan/Module-Build/lib/Module/Build/PPMMaker.pm +++ b/cpan/Module-Build/lib/Module/Build/PPMMaker.pm @@ -1,8 +1,9 @@ package Module::Build::PPMMaker; use strict; +use Config; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; # This code is mostly borrowed from ExtUtils::MM_Unix 6.10_03, with a @@ -34,7 +35,6 @@ sub make_ppd { my $method = "dist_$info"; $dist{$info} = $build->$method() or die "Can't determine distribution's $info\n"; } - $dist{version} = $self->_ppd_version($dist{version}); $self->_simple_xml_escape($_) foreach $dist{abstract}, @{$dist{author}}; @@ -42,21 +42,17 @@ sub make_ppd { # various licenses my $ppd = <<"PPD"; <SOFTPKG NAME=\"$dist{name}\" VERSION=\"$dist{version}\"> - <TITLE>$dist{name}</TITLE> <ABSTRACT>$dist{abstract}</ABSTRACT> @{[ join "\n", map " <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]} <IMPLEMENTATION> PPD - # TODO: We could set <IMPLTYPE VALUE="PERL" /> or maybe - # <IMPLTYPE VALUE="PERL/XS" /> ??? - # We don't include recommended dependencies because PPD has no way # to distinguish them from normal dependencies. We don't include # build_requires dependencies because the PPM installer doesn't # build or test before installing. And obviously we don't include # conflicts either. - + foreach my $type (qw(requires)) { my $prereq = $build->$type(); while (my ($modname, $spec) = each %$prereq) { @@ -73,27 +69,18 @@ PPD } } - # Another hack - dependencies are on modules, but PPD expects - # them to be on distributions (I think). - $modname =~ s/::/-/g; - - $ppd .= sprintf(<<'EOF', $modname, $self->_ppd_version($min_version)); - <DEPENDENCY NAME="%s" VERSION="%s" /> -EOF + # PPM4 spec requires a '::' for top level modules + $modname .= '::' unless $modname =~ /::/; + $ppd .= qq! <REQUIRE NAME="$modname" VERSION="$min_version" />\n!; } } # We only include these tags if this module involves XS, on the - # assumption that pure Perl modules will work on any OS. PERLCORE, - # unfortunately, seems to indicate that a module works with _only_ - # that version of Perl, and so is only appropriate when a module - # uses XS. + # assumption that pure Perl modules will work on any OS. if (keys %{$build->find_xs_files}) { my $perl_version = $self->_ppd_version($build->perl_version); - $ppd .= sprintf(<<'EOF', $perl_version, $^O, $self->_varchname($build->config) ); - <PERLCORE VERSION="%s" /> - <OS NAME="%s" /> + $ppd .= sprintf(<<'EOF', $self->_varchname($build->config) ); <ARCHITECTURE NAME="%s" /> EOF } @@ -113,7 +100,9 @@ EOF my $ppd_file = "$dist{name}.ppd"; my $fh = IO::File->new(">$ppd_file") or die "Cannot write to $ppd_file: $!"; - $fh->binmode(":utf8") if $fh->can("binmode"); + + $fh->binmode(":utf8") + if $fh->can('binmode') && $] >= 5.008 && $Config{useperlio}; print $fh $ppd; close $fh; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/Amiga.pm b/cpan/Module-Build/lib/Module/Build/Platform/Amiga.pm index 5ce8cf58a2..1b796d42c0 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/Amiga.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/Amiga.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::Amiga; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/Default.pm b/cpan/Module-Build/lib/Module/Build/Platform/Default.pm index df29af5f68..6c9391621d 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/Default.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/Default.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::Default; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/EBCDIC.pm b/cpan/Module-Build/lib/Module/Build/Platform/EBCDIC.pm index d68836c1a3..25fb528d9d 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/EBCDIC.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/EBCDIC.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::EBCDIC; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/MPEiX.pm b/cpan/Module-Build/lib/Module/Build/Platform/MPEiX.pm index a835c30d49..3d44c520d0 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/MPEiX.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/MPEiX.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::MPEiX; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/MacOS.pm b/cpan/Module-Build/lib/Module/Build/Platform/MacOS.pm index 9c9281adac..8a35afb658 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/MacOS.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/MacOS.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::MacOS; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; use vars qw(@ISA); diff --git a/cpan/Module-Build/lib/Module/Build/Platform/RiscOS.pm b/cpan/Module-Build/lib/Module/Build/Platform/RiscOS.pm index c240750c46..cad70baabf 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/RiscOS.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/RiscOS.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::RiscOS; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/Unix.pm b/cpan/Module-Build/lib/Module/Build/Platform/Unix.pm index 879ca3ad4e..3e7d79ab97 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/Unix.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/Unix.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::Unix; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/VMS.pm b/cpan/Module-Build/lib/Module/Build/Platform/VMS.pm index 3305154b2d..bdea755558 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/VMS.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/VMS.pm @@ -2,9 +2,10 @@ package Module::Build::Platform::VMS; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; +use Config; use vars qw(@ISA); @ISA = qw(Module::Build::Base); @@ -131,22 +132,22 @@ sub _quote_args { # or if we get a single arg that is an array reference, quote the # elements of it and return the reference. my ($self, @args) = @_; - my $got_arrayref = (scalar(@args) == 1 - && UNIVERSAL::isa($args[0], 'ARRAY')) - ? 1 + my $got_arrayref = (scalar(@args) == 1 + && UNIVERSAL::isa($args[0], 'ARRAY')) + ? 1 : 0; # Do not quote qualifiers that begin with '/'. - map { if (!/^\//) { + map { if (!/^\//) { $_ =~ s/\"/""/g; # escape C<"> by doubling $_ = q(").$_.q("); } } - ($got_arrayref ? @{$args[0]} + ($got_arrayref ? @{$args[0]} : @args ); - return $got_arrayref ? $args[0] + return $got_arrayref ? $args[0] : join(' ', @args); } @@ -173,6 +174,62 @@ sub _backticks { return `$cmd $args`; } +=item find_command + +Local an executable program + +=cut + +sub find_command { + my ($self, $command) = @_; + + # a lot of VMS executables have a symbol defined + # check those first + if ( $^O eq 'VMS' ) { + require VMS::DCLsym; + my $syms = VMS::DCLsym->new; + return $command if scalar $syms->getsym( uc $command ); + } + + $self->SUPER::find_command($command); +} + +# _maybe_command copied from ExtUtils::MM_VMS::maybe_command + +=item _maybe_command (override) + +Follows VMS naming conventions for executable files. +If the name passed in doesn't exactly match an executable file, +appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> +to check for DCL procedure. If this fails, checks directories in DCL$PATH +and finally F<Sys$System:> for an executable file having the name specified, +with or without the F<.Exe>-equivalent suffix. + +=cut + +sub _maybe_command { + my($self,$file) = @_; + return $file if -x $file && ! -d _; + my(@dirs) = (''); + my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); + + if ($file !~ m![/:>\]]!) { + for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { + my $dir = $ENV{"DCL\$PATH;$i"}; + $dir .= ':' unless $dir =~ m%[\]:]$%; + push(@dirs,$dir); + } + push(@dirs,'Sys$System:'); + foreach my $dir (@dirs) { + my $sysfile = "$dir$file"; + foreach my $ext (@exts) { + return $file if -x "$sysfile$ext" && ! -d _; + } + } + } + return; +} + =item do_system Override to ensure that we quote the arguments but not the command. @@ -182,7 +239,7 @@ Override to ensure that we quote the arguments but not the command. sub do_system { # The command must not be quoted but the arguments to it must be. my ($self, @cmd) = @_; - $self->log_info("@cmd\n"); + $self->log_verbose("@cmd\n"); my $cmd = shift @cmd; my $args = $self->_quote_args(@cmd); return !system("$cmd $args"); @@ -205,7 +262,7 @@ sub oneliner { =item _infer_xs_spec -Inherit the standard version but tweak the library file name to be +Inherit the standard version but tweak the library file name to be something Dynaloader can find. =cut @@ -250,7 +307,7 @@ sub rscan_dir { =item dist_dir -Inherit the standard version but replace embedded dots with underscores because +Inherit the standard version but replace embedded dots with underscores because a dot is the directory delimiter on VMS. =cut @@ -265,7 +322,7 @@ sub dist_dir { =item man3page_name -Inherit the standard version but chop the extra manpage delimiter off the front if +Inherit the standard version but chop the extra manpage delimiter off the front if there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'. =cut @@ -367,7 +424,7 @@ sub _detildefy { $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs); } - + # Now put the two cases back together $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file); @@ -446,7 +503,7 @@ sub _unix_rpt { $unix_rpt = VMS::Feature::current("filename_unix_report"); } else { my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; } return $unix_rpt; } @@ -459,7 +516,7 @@ sub _efs { $efs = VMS::Feature::current("efs_charset"); } else { my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; - $efs = $env_efs =~ /^[ET1]/i; + $efs = $env_efs =~ /^[ET1]/i; } return $efs; } diff --git a/cpan/Module-Build/lib/Module/Build/Platform/VOS.pm b/cpan/Module-Build/lib/Module/Build/Platform/VOS.pm index be46a80416..02b2dcc5c9 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/VOS.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/VOS.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::VOS; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Base; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/Windows.pm b/cpan/Module-Build/lib/Module/Build/Platform/Windows.pm index 6cf9da9cc3..d5602c5b20 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/Windows.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/Windows.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::Windows; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Config; @@ -39,7 +39,7 @@ sub ACTION_realclean { if ( lc $basename eq lc $self->build_script ) { if ( $self->build_bat ) { - $self->log_info("Deleting $basename.bat\n"); + $self->log_verbose("Deleting $basename.bat\n"); my $full_progname = $0; $full_progname =~ s/(?:\.bat)?$/.bat/i; @@ -273,6 +273,27 @@ sub do_system { return !$status; } +# Copied from ExtUtils::MM_Win32 +sub _maybe_command { + my($self,$file) = @_; + my @e = exists($ENV{'PATHEXT'}) + ? split(/;/, $ENV{PATHEXT}) + : qw(.com .exe .bat .cmd); + my $e = ''; + for (@e) { $e .= "\Q$_\E|" } + chop $e; + # see if file ends in one of the known extensions + if ($file =~ /($e)$/i) { + return $file if -e $file; + } + else { + for (@e) { + return "$file$_" if -e "$file$_"; + } + } + return; +} + 1; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/aix.pm b/cpan/Module-Build/lib/Module/Build/Platform/aix.pm index 45feb3cdd4..a5db1c5711 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/aix.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/aix.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::aix; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Platform::Unix; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/cygwin.pm b/cpan/Module-Build/lib/Module/Build/Platform/cygwin.pm index 62a6461ce2..c176c3954f 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/cygwin.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/cygwin.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::cygwin; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Platform::Unix; @@ -13,6 +13,22 @@ sub manpage_separator { '.' } +# Copied from ExtUtils::MM_Cygwin::maybe_command() +# If our path begins with F</cygdrive/> then we use C<ExtUtils::MM_Win32> +# to determine if it may be a command. Otherwise we use the tests +# from C<ExtUtils::MM_Unix>. + +sub _maybe_command { + my ($self, $file) = @_; + + if ($file =~ m{^/cygdrive/}i) { + require Module::Build::Platform::Win32; + return Module::Build::Platform::Win32->_maybe_command($file); + } + + return $self->SUPER::_maybe_command($file); +} + 1; __END__ diff --git a/cpan/Module-Build/lib/Module/Build/Platform/darwin.pm b/cpan/Module-Build/lib/Module/Build/Platform/darwin.pm index 39e9e36911..d9a82788a4 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/darwin.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/darwin.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::darwin; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Platform::Unix; diff --git a/cpan/Module-Build/lib/Module/Build/Platform/os2.pm b/cpan/Module-Build/lib/Module/Build/Platform/os2.pm index ace01a3291..194dd8523f 100644 --- a/cpan/Module-Build/lib/Module/Build/Platform/os2.pm +++ b/cpan/Module-Build/lib/Module/Build/Platform/os2.pm @@ -2,7 +2,7 @@ package Module::Build::Platform::os2; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use Module::Build::Platform::Unix; @@ -13,6 +13,16 @@ sub manpage_separator { '.' } sub have_forkpipe { 0 } +# Copied from ExtUtils::MM_OS2::maybe_command +sub _maybe_command { + my($self,$file) = @_; + $file =~ s,[/\\]+,/,g; + return $file if -x $file && ! -d _; + return "$file.exe" if -x "$file.exe" && ! -d _; + return "$file.cmd" if -x "$file.cmd" && ! -d _; + return; +} + 1; __END__ diff --git a/cpan/Module-Build/lib/Module/Build/PodParser.pm b/cpan/Module-Build/lib/Module/Build/PodParser.pm index b17b80b189..bb34b2b0b3 100644 --- a/cpan/Module-Build/lib/Module/Build/PodParser.pm +++ b/cpan/Module-Build/lib/Module/Build/PodParser.pm @@ -2,7 +2,7 @@ package Module::Build::PodParser; use strict; use vars qw($VERSION); -$VERSION = '0.35'; +$VERSION = '0.35_09'; $VERSION = eval $VERSION; use vars qw(@ISA); @@ -42,7 +42,7 @@ sub _myparse_from_filehandle { my @author; while (<$fh>) { - next unless /^=head1\s+AUTHORS?/ ... /^=/; + next unless /^=head1\s+AUTHORS?/i ... /^=/; next if /^=/; push @author, $_ if /\@/; } @@ -92,10 +92,10 @@ sub textblock { my ($self, $text) = @_; $text =~ s/^\s+//; $text =~ s/\s+$//; - if ($self->{_head} eq 'NAME') { + if (uc $self->{_head} eq 'NAME') { my ($name, $abstract) = split( /\s+-\s+/, $text, 2 ); $self->{abstract} = $abstract; - } elsif ($self->{_head} =~ /^AUTHORS?$/) { + } elsif ($self->{_head} =~ /^AUTHORS?$/i) { push @{$self->{author}}, $text if $text =~ /\@/; } } diff --git a/cpan/Module-Build/lib/Module/Build/YAML.pm b/cpan/Module-Build/lib/Module/Build/YAML.pm index 4a181ad1c9..af06f35f80 100644 --- a/cpan/Module-Build/lib/Module/Build/YAML.pm +++ b/cpan/Module-Build/lib/Module/Build/YAML.pm @@ -1,161 +1,600 @@ +# Adapted from YAML::Tiny 1.40 package Module::Build::YAML; use strict; -use vars qw($VERSION @EXPORT @EXPORT_OK); -$VERSION = "0.50"; -@EXPORT = (); -@EXPORT_OK = qw(Dump Load DumpFile LoadFile); +use Carp 'croak'; +# UTF Support? +sub HAVE_UTF8 () { $] >= 5.007003 } +BEGIN { + if ( HAVE_UTF8 ) { + # The string eval helps hide this from Test::MinimumVersion + eval "require utf8;"; + die "Failed to load UTF-8 support" if $@; + } + + # Class structure + require 5.004; + + $Module::Build::YAML::VERSION = '1.40'; + + # Error storage + $Module::Build::YAML::errstr = ''; +} + +# The character class of all characters we need to escape +# NOTE: Inlined, since it's only used once +# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]'; + +# Printed form of the unprintable characters in the lowest range +# of ASCII characters, listed by ASCII ordinal position. +my @UNPRINTABLE = qw( + z x01 x02 x03 x04 x05 x06 a + x08 t n v f r x0e x0f + x10 x11 x12 x13 x14 x15 x16 x17 + x18 x19 x1a e x1c x1d x1e x1f +); + +# Printable characters for escapes +my %UNESCAPES = ( + z => "\x00", a => "\x07", t => "\x09", + n => "\x0a", v => "\x0b", f => "\x0c", + r => "\x0d", e => "\x1b", '\\' => '\\', +); + +# Special magic boolean words +my %QUOTE = map { $_ => 1 } qw{ + null Null NULL + y Y yes Yes YES n N no No NO + true True TRUE false False FALSE + on On ON off Off OFF +}; + +##################################################################### +# Implementation + +# Create an empty Module::Build::YAML object sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = {}; - bless $self, $class; - return($self); + my $class = shift; + bless [ @_ ], $class; } -sub Dump { - shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__); - my $yaml = ""; - foreach my $item (@_) { - $yaml .= "---\n"; - $yaml .= &_yaml_chunk("", $item); - } - return $yaml; +# Create an object from a file +sub read { + my $class = ref $_[0] ? ref shift : shift; + + # Check the file + my $file = shift or return $class->_error( 'You did not specify a file name' ); + return $class->_error( "File '$file' does not exist" ) unless -e $file; + return $class->_error( "'$file' is a directory, not a file" ) unless -f _; + return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; + + # Slurp in the file + local $/ = undef; + local *CFG; + unless ( open(CFG, $file) ) { + return $class->_error("Failed to open file '$file': $!"); + } + my $contents = <CFG>; + unless ( close(CFG) ) { + return $class->_error("Failed to close file '$file': $!"); + } + + $class->read_string( $contents ); } -sub Load { - shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__); - die "not yet implemented"; +# Create an object from a string +sub read_string { + my $class = ref $_[0] ? ref shift : shift; + my $self = bless [], $class; + my $string = $_[0]; + unless ( defined $string ) { + return $self->_error("Did not provide a string to load"); + } + + # Byte order marks + # NOTE: Keeping this here to educate maintainers + # my %BOM = ( + # "\357\273\277" => 'UTF-8', + # "\376\377" => 'UTF-16BE', + # "\377\376" => 'UTF-16LE', + # "\377\376\0\0" => 'UTF-32LE' + # "\0\0\376\377" => 'UTF-32BE', + # ); + if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) { + return $self->_error("Stream has a non UTF-8 BOM"); + } else { + # Strip UTF-8 bom if found, we'll just ignore it + $string =~ s/^\357\273\277//; + } + + # Try to decode as utf8 + utf8::decode($string) if HAVE_UTF8; + + # Check for some special cases + return $self unless length $string; + unless ( $string =~ /[\012\015]+\z/ ) { + return $self->_error("Stream does not end with newline character"); + } + + # Split the file into lines + my @lines = grep { ! /^\s*(?:\#.*)?\z/ } + split /(?:\015{1,2}\012|\015|\012)/, $string; + + # Strip the initial YAML header + @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; + + # A nibbling parser + while ( @lines ) { + # Do we have a document header? + if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { + # Handle scalar documents + shift @lines; + if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { + push @$self, $self->_read_scalar( "$1", [ undef ], \@lines ); + next; + } + } + + if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { + # A naked document + push @$self, undef; + while ( @lines and $lines[0] !~ /^---/ ) { + shift @lines; + } + + } elsif ( $lines[0] =~ /^\s*\-/ ) { + # An array at the root + my $document = [ ]; + push @$self, $document; + $self->_read_array( $document, [ 0 ], \@lines ); + + } elsif ( $lines[0] =~ /^(\s*)\S/ ) { + # A hash at the root + my $document = { }; + push @$self, $document; + $self->_read_hash( $document, [ length($1) ], \@lines ); + + } else { + croak("Module::Build::YAML failed to classify the line '$lines[0]'"); + } + } + + $self; } -# This is basically copied out of YAML.pm and simplified a little. -sub DumpFile { - shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__); - my $filename = shift; - local $/ = "\n"; # reset special to "sane" - my $mode = '>'; - if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) { - ($mode, $filename) = ($1, $2); - } - open my $OUT, "$mode $filename" - or die "Can't open $filename for writing: $!"; - binmode($OUT, ':utf8') if $] >= 5.008; - print $OUT Dump(@_); - close $OUT; -} - -# This is basically copied out of YAML.pm and simplified a little. -sub LoadFile { - shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__); - my $filename = shift; - open my $IN, $filename - or die "Can't open $filename for reading: $!"; - binmode($IN, ':utf8') if $] >= 5.008; - return Load(do { local $/; <$IN> }); - close $IN; -} - -sub _yaml_chunk { - my ($indent, $values) = @_; - my $yaml_chunk = ""; - my $ref = ref($values); - my ($value, @allkeys, %keyseen); - if (!$ref) { # a scalar - $yaml_chunk .= &_yaml_value($values) . "\n"; - } - elsif ($ref eq "ARRAY") { - foreach $value (@$values) { - $yaml_chunk .= "$indent-"; - $ref = ref($value); - if (!$ref) { - $yaml_chunk .= " " . &_yaml_value($value) . "\n"; - } - else { - $yaml_chunk .= "\n"; - $yaml_chunk .= &_yaml_chunk("$indent ", $value); - } - } - } - else { # assume "HASH" - if ($values->{_order} && ref($values->{_order}) eq "ARRAY") { - @allkeys = @{$values->{_order}}; - $values = { %$values }; - delete $values->{_order}; - } - push(@allkeys, sort keys %$values); - foreach my $key (@allkeys) { - next if (!defined $key || $key eq "" || $keyseen{$key}); - $keyseen{$key} = 1; - $yaml_chunk .= "$indent$key:"; - $value = $values->{$key}; - $ref = ref($value); - if (!$ref) { - $yaml_chunk .= " " . &_yaml_value($value) . "\n"; - } - else { - $yaml_chunk .= "\n"; - $yaml_chunk .= &_yaml_chunk("$indent ", $value); - } - } - } - return($yaml_chunk); -} - -sub _yaml_value { - my ($value) = @_; - # undefs become ~ - return '~' if not defined $value; - - # empty strings will become empty strings - return '""' if $value eq ''; - - # allow simple scalars (without embedded quote chars) to be unquoted - # (includes $%_+=-\;:,./) - return $value if $value !~ /["'`~\n!\@\#^\&\*\(\)\{\}\[\]\|<>\?]/; - - # quote and escape strings with special values - return "'$value'" - if $value !~ /['`~\n!\#^\&\*\(\)\{\}\[\]\|\?]/; # nothing but " or @ or < or > (email addresses) - - $value =~ s/\n/\\n/g; # handle embedded newlines - $value =~ s/"/\\"/g; # handle embedded quotes - return qq{"$value"}; +# Deparse a scalar string to the actual scalar +sub _read_scalar { + my ($self, $string, $indent, $lines) = @_; + + # Trim trailing whitespace + $string =~ s/\s*\z//; + + # Explitic null/undef + return undef if $string eq '~'; + + # Quotes + if ( $string =~ /^\'(.*?)\'\z/ ) { + return '' unless defined $1; + $string = $1; + $string =~ s/\'\'/\'/g; + return $string; + } + if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) { + # Reusing the variable is a little ugly, + # but avoids a new variable and a string copy. + $string = $1; + $string =~ s/\\"/"/g; + $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex; + return $string; + } + + # Special cases + if ( $string =~ /^[\'\"!&]/ ) { + croak("Module::Build::YAML does not support a feature in line '$lines->[0]'"); + } + return {} if $string eq '{}'; + return [] if $string eq '[]'; + + # Regular unquoted string + return $string unless $string =~ /^[>|]/; + + # Error + croak("Module::Build::YAML failed to find multi-line scalar content") unless @$lines; + + # Check the indent depth + $lines->[0] =~ /^(\s*)/; + $indent->[-1] = length("$1"); + if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { + croak("Module::Build::YAML found bad indenting in line '$lines->[0]'"); + } + + # Pull the lines + my @multiline = (); + while ( @$lines ) { + $lines->[0] =~ /^(\s*)/; + last unless length($1) >= $indent->[-1]; + push @multiline, substr(shift(@$lines), length($1)); + } + + my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; + my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; + return join( $j, @multiline ) . $t; } -1; +# Parse an array +sub _read_array { + my ($self, $array, $indent, $lines) = @_; -__END__ + while ( @$lines ) { + # Check for a new document + if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { + while ( @$lines and $lines->[0] !~ /^---/ ) { + shift @$lines; + } + return 1; + } + + # Check the indent level + $lines->[0] =~ /^(\s*)/; + if ( length($1) < $indent->[-1] ) { + return 1; + } elsif ( length($1) > $indent->[-1] ) { + croak("Module::Build::YAML found bad indenting in line '$lines->[0]'"); + } + + if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { + # Inline nested hash + my $indent2 = length("$1"); + $lines->[0] =~ s/-/ /; + push @$array, { }; + $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); + + } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { + # Array entry with a value + shift @$lines; + push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines ); + + } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { + shift @$lines; + unless ( @$lines ) { + push @$array, undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)\-/ ) { + my $indent2 = length("$1"); + if ( $indent->[-1] == $indent2 ) { + # Null array entry + push @$array, undef; + } else { + # Naked indenter + push @$array, [ ]; + $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines ); + } + + } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { + push @$array, { }; + $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines ); + + } else { + croak("Module::Build::YAML failed to classify line '$lines->[0]'"); + } + + } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { + # This is probably a structure like the following... + # --- + # foo: + # - list + # bar: value + # + # ... so lets return and let the hash parser handle it + return 1; + + } else { + croak("Module::Build::YAML failed to classify line '$lines->[0]'"); + } + } + + return 1; +} + +# Parse an array +sub _read_hash { + my ($self, $hash, $indent, $lines) = @_; + + while ( @$lines ) { + # Check for a new document + if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { + while ( @$lines and $lines->[0] !~ /^---/ ) { + shift @$lines; + } + return 1; + } + + # Check the indent level + $lines->[0] =~ /^(\s*)/; + if ( length($1) < $indent->[-1] ) { + return 1; + } elsif ( length($1) > $indent->[-1] ) { + croak("Module::Build::YAML found bad indenting in line '$lines->[0]'"); + } + + # Get the key + unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) { + if ( $lines->[0] =~ /^\s*[?\'\"]/ ) { + croak("Module::Build::YAML does not support a feature in line '$lines->[0]'"); + } + croak("Module::Build::YAML failed to classify line '$lines->[0]'"); + } + my $key = $1; + + # Do we have a value? + if ( length $lines->[0] ) { + # Yes + $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines ); + } else { + # An indent + shift @$lines; + unless ( @$lines ) { + $hash->{$key} = undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)-/ ) { + $hash->{$key} = []; + $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines ); + } elsif ( $lines->[0] =~ /^(\s*)./ ) { + my $indent2 = length("$1"); + if ( $indent->[-1] >= $indent2 ) { + # Null hash entry + $hash->{$key} = undef; + } else { + $hash->{$key} = {}; + $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); + } + } + } + } + + return 1; +} + +# Save an object to a file +sub write { + my $self = shift; + my $file = shift or return $self->_error('No file name provided'); + + # Write it to the file + open( CFG, '>' . $file ) or return $self->_error( + "Failed to open file '$file' for writing: $!" + ); + print CFG $self->write_string; + close CFG; + + return 1; +} -=head1 NAME +# Save an object to a string +sub write_string { + my $self = shift; + return '' unless @$self; -Module::Build::YAML - Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed + # Iterate over the documents + my $indent = 0; + my @lines = (); + foreach my $cursor ( @$self ) { + push @lines, '---'; -=head1 SYNOPSIS + # An empty document + if ( ! defined $cursor ) { + # Do nothing - use Module::Build::YAML; + # A scalar document + } elsif ( ! ref $cursor ) { + $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent ); - ... + # A list at the root + } elsif ( ref $cursor eq 'ARRAY' ) { + unless ( @$cursor ) { + $lines[-1] .= ' []'; + next; + } + push @lines, $self->_write_array( $cursor, $indent, {} ); -=head1 DESCRIPTION + # A hash at the root + } elsif ( ref $cursor eq 'HASH' ) { + unless ( %$cursor ) { + $lines[-1] .= ' {}'; + next; + } + push @lines, $self->_write_hash( $cursor, $indent, {} ); -Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed. + } else { + croak("Cannot serialize " . ref($cursor)); + } + } -Currently, this amounts to the ability to write META.yml files when C<perl Build distmeta> -is executed via the Dump() and DumpFile() functions/methods. + join '', map { "$_\n" } @lines; +} + +sub _write_scalar { + my $string = $_[1]; + return '~' unless defined $string; + return "''" unless length $string; + if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) { + $string =~ s/\\/\\\\/g; + $string =~ s/"/\\"/g; + $string =~ s/\n/\\n/g; + $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; + return qq|"$string"|; + } + if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) { + return "'$string'"; + } + return $string; +} + +sub _write_array { + my ($self, $array, $indent, $seen) = @_; + if ( $seen->{refaddr($array)}++ ) { + die "Module::Build::YAML does not support circular references"; + } + my @lines = (); + foreach my $el ( @$array ) { + my $line = (' ' x $indent) . '-'; + my $type = ref $el; + if ( ! $type ) { + $line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); + push @lines, $line; + + } elsif ( $type eq 'ARRAY' ) { + if ( @$el ) { + push @lines, $line; + push @lines, $self->_write_array( $el, $indent + 1, $seen ); + } else { + $line .= ' []'; + push @lines, $line; + } + + } elsif ( $type eq 'HASH' ) { + if ( keys %$el ) { + push @lines, $line; + push @lines, $self->_write_hash( $el, $indent + 1, $seen ); + } else { + $line .= ' {}'; + push @lines, $line; + } -=head1 AUTHOR + } else { + die "Module::Build::YAML does not support $type references"; + } + } -Stephen Adkins <spadkins@gmail.com> + @lines; +} + +sub _write_hash { + my ($self, $hash, $indent, $seen) = @_; + if ( $seen->{refaddr($hash)}++ ) { + die "Module::Build::YAML does not support circular references"; + } + my @lines = (); + foreach my $name ( sort keys %$hash ) { + my $el = $hash->{$name}; + my $line = (' ' x $indent) . "$name:"; + my $type = ref $el; + if ( ! $type ) { + $line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); + push @lines, $line; + + } elsif ( $type eq 'ARRAY' ) { + if ( @$el ) { + push @lines, $line; + push @lines, $self->_write_array( $el, $indent + 1, $seen ); + } else { + $line .= ' []'; + push @lines, $line; + } -=head1 COPYRIGHT + } elsif ( $type eq 'HASH' ) { + if ( keys %$el ) { + push @lines, $line; + push @lines, $self->_write_hash( $el, $indent + 1, $seen ); + } else { + $line .= ' {}'; + push @lines, $line; + } -Copyright (c) 2006. Stephen Adkins. All rights reserved. + } else { + die "Module::Build::YAML does not support $type references"; + } + } -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. + @lines; +} -See L<http://www.perl.com/perl/misc/Artistic.html> +# Set error +sub _error { + $Module::Build::YAML::errstr = $_[1]; + undef; +} -=cut +# Retrieve error +sub errstr { + $Module::Build::YAML::errstr; +} + +##################################################################### +# YAML Compatibility + +sub Dump { + Module::Build::YAML->new(@_)->write_string; +} + +sub Load { + my $self = Module::Build::YAML->read_string(@_); + unless ( $self ) { + croak("Failed to load YAML document from string"); + } + if ( wantarray ) { + return @$self; + } else { + # To match YAML.pm, return the last document + return $self->[-1]; + } +} + +BEGIN { + *freeze = *Dump; + *thaw = *Load; +} + +sub DumpFile { + my $file = shift; + Module::Build::YAML->new(@_)->write($file); +} + +sub LoadFile { + my $self = Module::Build::YAML->read($_[0]); + unless ( $self ) { + croak("Failed to load YAML document from '" . ($_[0] || '') . "'"); + } + if ( wantarray ) { + return @$self; + } else { + # Return only the last document to match YAML.pm, + return $self->[-1]; + } +} + +##################################################################### +# Use Scalar::Util if possible, otherwise emulate it + +BEGIN { + eval { + require Scalar::Util; + }; + if ( $@ ) { + # Failed to load Scalar::Util + eval <<'END_PERL'; +sub refaddr { + my $pkg = ref($_[0]) or return undef; + if (!!UNIVERSAL::can($_[0], 'can')) { + bless $_[0], 'Scalar::Util::Fake'; + } else { + $pkg = undef; + } + "$_[0]" =~ /0x(\w+)/; + my $i = do { local $^W; hex $1 }; + bless $_[0], $pkg if defined $pkg; + $i; +} +END_PERL + } else { + Scalar::Util->import('refaddr'); + } +} + +1; + +__END__ diff --git a/cpan/Module-Build/lib/inc/latest.pm b/cpan/Module-Build/lib/inc/latest.pm new file mode 100644 index 0000000000..d63dff8fac --- /dev/null +++ b/cpan/Module-Build/lib/inc/latest.pm @@ -0,0 +1,250 @@ +package inc::latest; +use strict; +use vars qw($VERSION); +$VERSION = '0.35_09'; +$VERSION = eval $VERSION; + +use Carp; +use File::Basename (); +use File::Spec (); +use File::Path (); +use IO::File (); +use File::Copy (); + +# track and return modules loaded by inc::latest +my @loaded_modules; +sub loaded_modules {@loaded_modules} + +# must ultimately "goto" the import routine of the module to be loaded +# so that the calling package is correct when $mod->import() runs. +sub import { + my ($package, $mod, @args) = @_; + return unless(defined $mod); + + my $inc_path = './inc/latest.pm'; + my $private_path = './inc/latest/private.pm'; + if(-e $inc_path) { + # delete our methods + delete $inc::latest::{$_} for(keys %inc::latest::); + # load the bundled module + require $inc_path; + require $private_path; + my $import = inc::latest->can('import'); + goto $import; + } + + # author mode - just record and load the modules + push(@loaded_modules, $mod); + require inc::latest::private; + goto \&inc::latest::private::_load_module; +} + +sub write { + my $package = shift; + my ($where, @preload) = @_; + + warn "should really be writing in inc/" unless $where =~ /inc$/; + + # write inc/latest.pm + File::Path::mkpath( $where ); + my $fh = IO::File->new( File::Spec->catfile($where,'latest.pm'), "w" ); + print {$fh} "# This stub created by inc::latest $VERSION\n"; + print {$fh} <<'HERE'; +package inc::latest; +use strict; +use vars '@ISA'; +require inc::latest::private; +@ISA = qw/inc::latest::private/; +HERE + if (@preload) { + print {$fh} "\npackage inc::latest::preload;\n"; + for my $mod (@preload) { + print {$fh} "inc::latest->import('$mod');\n"; + } + } + print {$fh} "\n1;\n"; + close $fh; + + # write inc/latest/private; + require inc::latest::private; + File::Path::mkpath( File::Spec->catdir( $where, 'latest' ) ); + my $from = $INC{'inc/latest/private.pm'}; + my $to = File::Spec->catfile($where,'latest','private.pm'); + File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!"; + + return 1; +} + +sub bundle_module { + my ($package, $module, $where) = @_; + + # create inc/inc_$foo + (my $dist = $module) =~ s{::}{-}g; + my $inc_lib = File::Spec->catdir($where,"inc_$dist"); + File::Path::mkpath $inc_lib; + + # get list of files to copy + require ExtUtils::Installed; + # workaround buggy EU::Installed check of @INC + my $inst = ExtUtils::Installed->new(extra_libs => [@INC]); + my $packlist = $inst->packlist( $module ) or die "Couldn't find packlist"; + my @files = grep { /\.pm$/ } keys %$packlist; + + + # figure out prefix + my $mod_path = quotemeta $package->_mod2path( $module ); + my ($prefix) = grep { /$mod_path$/ } @files; + $prefix =~ s{$mod_path$}{}; + + # copy files + for my $from ( @files ) { + next unless $from =~ /\.pm$/; + (my $mod_path = $from) =~ s{^\Q$prefix\E}{}; + my $to = File::Spec->catfile( $inc_lib, $mod_path ); + File::Path::mkpath(File::Basename::dirname($to)); + File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!"; + } + return 1; +} + +# Translate a module name into a directory/file.pm to search for in @INC +sub _mod2path { + my ($self, $mod) = @_; + my @parts = split /::/, $mod; + $parts[-1] .= '.pm'; + return $parts[0] if @parts == 1; + return File::Spec->catfile(@parts); +} + +1; + + +=head1 NAME + +inc::latest - use modules bundled in inc/ if they are newer than installed ones + +=head1 SYNOPSIS + + # in Build.PL + use inc::latest 'Module::Build'; + +=head1 DESCRIPTION + +The C<inc::latest> module helps bootstrap configure-time dependencies for CPAN +distributions. These dependencies get bundled into the C<inc> directory within +a distribution and are used by Build.PL (or Makefile.PL). + +Arguments to C<inc::latest> are module names that are checked against both the +current C<@INC> array and against specially-named directories in C<inc>. If +the bundled verison is newer than the installed one (or the module isn't +installed, then, the bundled directory is added to the start of <@INC> and the +module is loaded from there. + +There are actually two variations of C<inc::latest> -- one for authors and one +for the C<inc> directory. For distribution authors, the C<inc::latest> +installed in the system will record modules loaded via C<inc::latest> and can +be used to create the bundled files in C<inc>, including writing the second +variation as C<inc/latest.pm>. + +This second C<inc::latest> is the one that is loaded in a distribution being +installed (e.g. from Build.PL). This bundled C<inc::latest> is the one +that determines which module to load. + +=head2 Special notes on bundling + +The C<inc::latest> module creates bundled directories based on the packlist +file of an installed distribution. Even though C<inc::latest> takes module +name arguments, it is better to think of it as bundling and making available +entire I<distributions>. When a module is loaded through C<inc::latest>, +it looks in all bundled distributions in C<inc/> for a newer module than +can be found in the existing C<@INC> array. + +Thus, the module-name provided should usually be the "top-level" module name of +a distribution, though this is not strictly required. For example, +L<Module::Build> has a number of heuristics to map module names to packlists, +allowing users to do things like this: + + use inc::latest 'Devel::AssertOS::Unix'; + +even though Devel::AssertOS::Unix is contained within the Devel-CheckOS +distribution. + +At the current time, packlists are required. Thus, bundling dual-core modules +may require a 'forced install' over versions in the latest version of perl +in order to create the necessary packlist for bundling. + +=head1 USAGE + +When calling C<use>, the bundled C<inc::latest> takes a single module name and +optional arguments to pass to that module's own import method. + + use 'inc::latest' 'Foo::Bar' qw/foo bar baz/; + +=head2 Author-mode + +You are in author-mode inc::latest if any of the Author-mode methods are +available. For example: + + if ( inc::latest->can('write') ) { + inc::latest->write('inc'); + } + +=over 4 + +=item loaded_modules() + + my @list = inc::latest->loaded_modules; + +This takes no arguments and always returns a list of module names requested for +loading via "use inc::latest 'MODULE'", regardless of wether the load was +successful or not. + +=item write() + + inc::latest->write( 'inc' ); + +This writes the bundled version of inc::latest to the directory name given as an +argument. It almost all cases, it should be 'C<inc>'. + +=item bundle_module() + + for my $mod ( inc::latest->loaded_modules ) { + inc::latest->bundle_module($mod, $dir); + } + +If $mod corresponds to a packlist, then this function creates a specially-named +directory in $dir and copies all .pm files from the modlist to the new +directory (which almost always should just be 'inc'). For example, if Foo::Bar +is the name of the module, and $dir is 'inc', then the directory would be +'inc/inc_Foo-Bar' and contain files like this: + + inc/inc_Foo-Bar/Foo/Bar.pm + +Currently, $mod B<must> have a packlist. If this is not the case (e.g. for a +dual-core module), then the bundling will fail. You may be able to create a +packlist by forced installing the module on top of the version that came with +core Perl. + +=back + +=head2 As bundled in inc/ + +All methods are private. Only the C<import> method is public. + +=head1 AUTHOR + +Eric Wilhelm <ewilhelm@cpan.org>, David Golden <dagolden@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2009 by Eric Wilhelm and David Golden + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Module::Build> + +=cut + diff --git a/cpan/Module-Build/lib/inc/latest/private.pm b/cpan/Module-Build/lib/inc/latest/private.pm new file mode 100644 index 0000000000..58ad0bc9ee --- /dev/null +++ b/cpan/Module-Build/lib/inc/latest/private.pm @@ -0,0 +1,101 @@ +package inc::latest::private; +use strict; +use vars qw($VERSION); +$VERSION = '0.35_09'; +$VERSION = eval $VERSION; + +use File::Spec; +use IO::File; + +# must ultimately "goto" the import routine of the module to be loaded +# so that the calling package is correct when $mod->import() runs. +sub import { + my ($package, $mod, @args) = @_; + my $file = $package->_mod2path($mod); + + if ($INC{$file}) { + # Already loaded, but let _load_module handle import args + goto \&_load_module; + } + + # A bundled copy must be present + my ($bundled, $bundled_dir) = $package->_search_bundled($file) + or die "No bundled copy of $mod found"; + + my $from_inc = $package->_search_INC($file); + unless ($from_inc) { + # Only bundled is available + unshift(@INC, $bundled_dir); + goto \&_load_module; + } + + if (_version($from_inc) >= _version($bundled)) { + # Ignore the bundled copy + goto \&_load_module; + } + + # Load the bundled copy + unshift(@INC, $bundled_dir); + goto \&_load_module; +} + +sub _version { + require ExtUtils::MakeMaker; + return ExtUtils::MM->parse_version(shift); +} + +# use "goto" for import to preserve caller +sub _load_module { + my $package = shift; # remaining @_ is ready for goto + my ($mod, @args) = @_; + eval "require $mod; 1" or die $@; + if ( my $import = $mod->can('import') ) { + goto $import; + } + return 1; +} + +sub _search_bundled { + my ($self, $file) = @_; + + my $mypath = 'inc'; + + local *DH; # Maintain 5.005 compatibility + opendir DH, $mypath or die "Can't open directory $mypath: $!"; + + while (defined(my $e = readdir DH)) { + next unless $e =~ /^inc_/; + my $try = File::Spec->catfile($mypath, $e, $file); + + return($try, File::Spec->catdir($mypath, $e)) if -e $try; + } + return; +} + +# Look for the given path in @INC. +sub _search_INC { + # TODO: doesn't handle coderefs or arrayrefs or objects in @INC, but + # it probably should + my ($self, $file) = @_; + + foreach my $dir (@INC) { + next if ref $dir; + my $try = File::Spec->catfile($dir, $file); + return $try if -e $try; + } + + return; +} + +# Translate a module name into a directory/file.pm to search for in @INC +sub _mod2path { + my ($self, $mod) = @_; + my @parts = split /::/, $mod; + $parts[-1] .= '.pm'; + return $parts[0] if @parts == 1; + return File::Spec->catfile(@parts); +} + +1; + + diff --git a/cpan/Module-Build/t/PL_files.t b/cpan/Module-Build/t/PL_files.t index a22171458c..68614c80e4 100644 --- a/cpan/Module-Build/t/PL_files.t +++ b/cpan/Module-Build/t/PL_files.t @@ -4,7 +4,7 @@ use strict; use lib 't/lib'; use MBTest tests => 8; use DistGen; -use Module::Build; +blib_load('Module::Build'); my $dist; diff --git a/cpan/Module-Build/t/README.pod b/cpan/Module-Build/t/README.pod new file mode 100644 index 0000000000..b2d0579d3e --- /dev/null +++ b/cpan/Module-Build/t/README.pod @@ -0,0 +1,94 @@ +=head1 A GUIDE TO WRITING TESTS FOR MODULE::BUILD + +This document provides tips on writing new tests for Module::Build. Please +note that many existing tests were written prior to these guidelines and +have many different styles. Please don't copy/paste old tests by rote without +considering better ways to test. See C<sample.t> for a starter test file. + +=head1 TEST FILE PREAMBLE + +Every Module::Build test should begin with the same preamble to ensure that the +test library is set properly and that the correct version of Module::Build is +being tested. + + use strict; + use lib 't/lib'; + use MBTest tests => 2; # or 'no_plan' + + blib_load('Module::Build'); + +The C<MBTest> module is in C<t/lib/> and subclasses Test::More. When loaded +it cleans up several environment variables that could cause problems, +tweaks C<@INC> and exports several helper functions. See that module for +details. + +=head1 CREATING A TEST DISTRIBUTION + +The C<DistGen> module in C<t/lib/> should be used to create sample +distributions for testing. It provides numerous helpful methods to +create a skeleton distribution, add files, change files, and so on. +Run C<perldoc> on C<t/lib/DistGen.pm> to see the documentation. + + # CREATE A TEST DISTRIBUTION + + use DistGen; + + # create dist object in a temp directory + my $dist = DistGen->new; + + # enter the test distribution directory before further testing + $dist->chdir_in; + + # generate the skeleton files + $dist->regen; + + +=head1 GETTING A MODULE::BUILD OBJECT + +From inside the test distribution, you can get the Module::Build object +configured in Build.PL using the C<new_from_context> method on the +dist object. This is just like Module::Build's C<new_from_context> except +it passes C<< quiet => 1 >> to avoid sending output to the terminal. +Use the Module::Build object to test the programmatic API. + + my $mb = $dist->new_from_context( quiet => 1 ); + isa_ok( $mb, "Module::Build" ); + is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); + +=head1 TESTING THE COMMAND LINE API + +The command line API is tested by running subprocesses, not via a Module::Build +object. The C<DistGen> object has helper methods for running C<Build.PL> and +C<Build> and passing arguments on the command line. + + $dist->run_build_pl( '--quiet' ); + $dist->run_build( 'test' ); + +=head1 TYPICAL TESTING CYCLE + +The typical testing cycle is to generate or modify a test distribution, either +through the C<DistGen> object or directly in the filesystem, then regenerate +the distribution and test it (or run command line tests and observe the +result.) + + # Modify the distribution + + $dist->change_build_pl( + { + module_name => $dist->name, + license => 'artistic', + } + ); + $dist->regen; + + # Get a new build object and test it + + $mb = $dist->new_from_context; + is( $mb->license, "artistic", "saw 'artistic' license" ); + + +=head1 COPYRIGHT + +This documentation is Copyright (C) 2009 by David Golden. You can redistribute +it and/or modify it under the same terms as Perl 5.10.0. + diff --git a/cpan/Module-Build/t/actions/installdeps.t b/cpan/Module-Build/t/actions/installdeps.t new file mode 100644 index 0000000000..95e221d0ad --- /dev/null +++ b/cpan/Module-Build/t/actions/installdeps.t @@ -0,0 +1,48 @@ +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 7; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in; + +$dist->change_build_pl( + module_name => $dist->name, + requires => { + 'File::Spec' => 9999, + }, + build_requires => { + 'Getopt::Long' => 9998, + }, + cpan_client => $^X . ' -le print($_)for($^X,@ARGV)', +)->regen; + +# get a Module::Build object and test with it +my $mb; +stdout_stderr_of( sub { $mb = $dist->new_from_context('verbose' => 1) } ); +isa_ok( $mb, "Module::Build" ); +like( $mb->cpan_client, qr/^\Q$^X\E/, "cpan_client is mocked with perl" ); + +my $out = stdout_of( sub { + $dist->run_build('installdeps') +}); +ok( length($out), "ran mocked Build installdeps"); +my $expected = quotemeta(Module::Build->find_command($^X)); +like( $out, qr/$expected/i, "relative cpan_client resolved relative to \$^X" ); +like( $out, qr/File::Spec/, "saw File::Spec prereq" ); +like( $out, qr/Getopt::Long/, "saw Getopt::Long prereq" ); + +$out = stdout_stderr_of( sub { + $dist->run_build('installdeps', '--cpan_client', 'ADLKASJDFLASDJ') +}); +like( $out, qr/cpan_client .* is not executable/, + "Build installdeps with bad cpan_client dies" +); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/cpan/Module-Build/t/add_property.t b/cpan/Module-Build/t/add_property.t index 6032b0929d..e0b25ae00f 100644 --- a/cpan/Module-Build/t/add_property.t +++ b/cpan/Module-Build/t/add_property.t @@ -2,12 +2,11 @@ use strict; use lib 't/lib'; -use MBTest tests => 29; +use MBTest tests => 27; #use MBTest 'no_plan'; use DistGen; -BEGIN { use_ok 'Module::Build' or die; } -ensure_blib 'Module::Build'; +blib_load 'Module::Build'; my $tmp = MBTest->tmpdir; my $dist = DistGen->new( dir => $tmp ); diff --git a/cpan/Module-Build/t/basic.t b/cpan/Module-Build/t/basic.t index f46be0a4c9..74c50b6178 100644 --- a/cpan/Module-Build/t/basic.t +++ b/cpan/Module-Build/t/basic.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 60; +use MBTest tests => 58; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; @@ -28,7 +27,7 @@ $dist->chdir_in; $mb = Module::Build->new( dist_name => $dist->name, dist_version => 7 ); ok $mb; - ok ! $mb->module_name; # Make sure it's defined + ok $mb->module_name; # Set via heuristics is $mb->dist_name, $dist->name; } @@ -163,10 +162,7 @@ $dist->chdir_in; is $args{foo}, 1; # revert test distribution to pristine state because we modified a file - $dist->remove; - $dist = DistGen->new( dir => $tmp ); - $dist->regen; - $dist->chdir_in; + $dist->regen( clean => 1 ); } # Test author stuff @@ -236,5 +232,3 @@ $dist->chdir_in; is_deeply $mb->include_dirs, ['/foo'], 'Should have single include dir'; } -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/bundle_inc.t b/cpan/Module-Build/t/bundle_inc.t new file mode 100644 index 0000000000..bbc3b86aaa --- /dev/null +++ b/cpan/Module-Build/t/bundle_inc.t @@ -0,0 +1,209 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; # or 'no_plan' +use DistGen; +use Config; +use IO::File; +use File::Spec; +use ExtUtils::Packlist; +use File::Path; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); + +if ( $ENV{PERL_CORE} ) { + plan skip_all => 'bundle_inc tests will never succeed in PERL_CORE'; +} +elsif ( Module::Build::ConfigData->feature('inc_bundling_support') ) { + plan tests => 18; +} else { + plan skip_all => 'inc_bundling_support feature is not enabled'; +} + +# need to do a temp install of M::B being tested to ensure a packlist +# is available for bundling + +my $current_mb = Module::Build->resume(); +my $temp_install = MBTest->tmpdir(); +my $arch = $Config{archname}; +my $lib_path = File::Spec->catdir($temp_install,qw/lib perl5/); +my $arch_path = File::Spec->catdir( $lib_path, $arch ); +mkpath ( $arch_path ); +ok( -d $arch_path, "created temporary M::B pseudo-install directory"); + +unshift @INC, $lib_path, $arch_path; +local $ENV{PERL5LIB} = join( $Config{path_sep}, + $lib_path, $arch_path, ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : () ) +); + +stdout_of( sub { $current_mb->dispatch('install', install_base => $temp_install) } ); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new( inc => 1 )->chdir_in->regen; + +# get a Module::Build object and test with it +my $mb = $dist->new_from_context(); # quiet by default +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); +is_deeply( $mb->bundle_inc, [ 'Module::Build' ], + "Module::Build is flagged for bundling" +); + +# see what gets bundled +stdout_stderr_of( sub { $mb->dispatch('distdir') } ); + +my $dist_inc = File::Spec->catdir($mb->dist_dir, 'inc'); +ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ), + "./inc/latest.pm created" +); + +ok( -d File::Spec->catdir( $dist_inc, 'inc_Module-Build' ), + "dist_dir/inc/inc_Module_Build created" +); + +my $mb_file = + File::Spec->catfile( $dist_inc, qw/inc_Module-Build Module Build.pm/ ); + +ok( -e $mb_file, + "dist_dir/inc/inc_Module_Build/Module/Build.pm created" +); + +ok( -e File::Spec->catfile( $dist_inc, qw/inc_Module-Build Module Build Base.pm/ ), + "dist_dir/inc/inc_Module_Build/Module/Build/Base.pm created" +); + +# Force bundled M::B to a higher version so it gets loaded +# This has failed on Win32 for no known reason, so we'll skip if +# we can't edit the file. + +eval { + my $fh; + $fh = IO::File->new($mb_file, "<") or die "Could not read $mb_file: $!"; + my $mb_code = do { local $/; <$fh> }; + $mb_code =~ s{\$VERSION\s+=\s+\S+}{\$VERSION = 9999;}; + $fh->close; + $fh = IO::File->new($mb_file, ">") or die "Could not write $mb_file: $!"; + print {$fh} $mb_code; + $fh->close; +}; + +my $err = $@; +diag $@ if $@; +SKIP: { + skip "Couldn't adjust \$VERSION in bundled M::B for testing", 10 + if $err; + + # test the bundling in dist_dir + chdir $mb->dist_dir; + + stdout_of( sub { Module::Build->run_perl_script('Build.PL',[],[]) } ); + + my $meta = IO::File->new('MYMETA.yml'); + ok( $meta, "found MYMETA.yml" ); + ok( scalar( grep { /generated_by:.*9999/ } <$meta> ), + "dist_dir Build.PL loaded bundled Module::Build" + ); + + #--------------------------------------------------------------------------# + # test identification of dependencies + #--------------------------------------------------------------------------# + + $dist->chdir_in; + + $dist->add_file( 'mylib/Foo.pm', << 'HERE' ); +package Foo; +our $VERSION = 1; +1; +HERE + + $dist->add_file( 'mylib/Bar.pm', << 'HERE' ); +package Bar; +use Foo; +our $VERSION = 42; +1; +HERE + + $dist->change_file( 'Build.PL', << "HERE" ); +use inc::latest 'Module::Build'; +use inc::latest 'Foo'; + +Module::Build->new( + module_name => '$dist->{name}', + license => 'perl', +)->create_build_script; +HERE + + $dist->regen( clean => 1 ); + + make_packlist($_,'mylib') for qw/Foo Bar/; + + # get a Module::Build object and test with it + my $abs_mylib = File::Spec->rel2abs('mylib'); + + + unshift @INC, $abs_mylib; + $mb = $dist->new_from_context(); # quiet by default + isa_ok( $mb, "Module::Build" ); + is_deeply( [sort @{$mb->bundle_inc}], [ 'Foo', 'Module::Build' ], + "Module::Build and Foo are flagged for bundling" + ); + + my $output = stdout_stderr_of( sub { $mb->dispatch('distdir') } ); + + ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ), + "./inc/latest.pm created" + ); + + ok( -d File::Spec->catdir( $dist_inc, 'inc_Foo' ), + "dist_dir/inc/inc_Foo created" + ); + + $dist->change_file( 'Build.PL', << "HERE" ); +use inc::latest 'Module::Build'; +use inc::latest 'Bar'; + +Module::Build->new( + module_name => '$dist->{name}', + license => 'perl', +)->create_build_script; +HERE + + $dist->regen( clean => 1 ); + make_packlist($_,'mylib') for qw/Foo Bar/; + + $mb = $dist->new_from_context(); # quiet by default + isa_ok( $mb, "Module::Build" ); + is_deeply( [sort @{$mb->bundle_inc}], [ 'Bar', 'Module::Build' ], + "Module::Build and Bar are flagged for bundling" + ); + + $output = stdout_stderr_of( sub { $mb->dispatch('distdir') } ); + + ok( -e File::Spec->catfile( $dist_inc, 'latest.pm' ), + "./inc/latest.pm created" + ); + + ok( -d File::Spec->catdir( $dist_inc, 'inc_Bar' ), + "dist_dir/inc/inc_Bar created" + ); +} + + +sub make_packlist { + my ($mod, $lib) = @_; + my $arch = $Config{archname}; + (my $mod_path = $mod) =~ s{::}{/}g; + my $mod_file = File::Spec->catfile( $lib, "$mod_path\.pm" ); + my $abs = File::Spec->rel2abs($mod_file); + my $packlist_path = File::Spec->catdir($lib, $arch, 'auto', $mod_path); + mkpath $packlist_path; + my $packlist = ExtUtils::Packlist->new; + $packlist->{$abs}++; + $packlist->write( File::Spec->catfile( $packlist_path, '.packlist' )); +} + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/cpan/Module-Build/t/compat.t b/cpan/Module-Build/t/compat.t index 88e5953408..f84b79b744 100644 --- a/cpan/Module-Build/t/compat.t +++ b/cpan/Module-Build/t/compat.t @@ -25,8 +25,8 @@ if ( $Config{make} && $^O ne 'VMS' ? find_in_path($Config{make}) : 1 ) { my $is_vms_mms = ($^O eq 'VMS') && ($Config{make} =~ /MM[SK]/i); -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); +blib_load('Module::Build::Version'); ######################### @@ -43,8 +43,8 @@ $dist->chdir_in; ######################### -use Module::Build; -use Module::Build::Compat; +blib_load('Module::Build'); +blib_load('Module::Build::Compat'); use Carp; $SIG{__WARN__} = \&Carp::cluck; @@ -72,10 +72,11 @@ $dist->change_build_pl({ license => 'perl', requires => { 'perl' => $], - 'File::Spec' => 0, + 'File::Spec' => 0.2, }, - build_requires => { - 'Test::More' => 0, + build_requires => { + 'Test::More' => 0, + 'File::Spec' => 0, }, PL_files => { 'foo.PL' => 'foo' }, }); @@ -90,8 +91,11 @@ $dist->regen; test_makefile_types( requires => { 'perl' => $], - 'File::Spec' => 0, + 'File::Spec' => 0.2, + }, + build_requires => { 'Test::More' => 0, + 'File::Spec' => 0, }, PL_files => { 'foo.PL' => 'foo', @@ -108,7 +112,7 @@ $dist->regen; # Create M::B instance but don't pollute STDOUT my $mb; -stdout_of( sub { +stdout_stderr_of( sub { $mb = Module::Build->new_from_context; }); ok $mb, "Module::Build->new_from_context"; @@ -131,7 +135,7 @@ ok $mb, "Module::Build->new_from_context"; # Makefile.PL - make sure it fails in the right way here. local @Foo::Builder::ISA = qw(Module::Build); my $foo_builder; - stdout_of( sub { + stdout_stderr_of( sub { $foo_builder = Foo::Builder->new_from_context; }); foreach my $style ('passthrough', 'small') { @@ -148,13 +152,13 @@ ok $mb, "Module::Build->new_from_context"; # Now make sure it can actually work. my $bar_builder; - stdout_of( sub { + stdout_stderr_of( sub { $bar_builder = Module::Build->subclass( class => 'Bar::Builder' )->new_from_context; }); foreach my $style ('passthrough', 'small') { create_makefile_pl($style, $bar_builder); my $result; - stdout_of( sub { + stdout_stderr_of( sub { $result = $mb->run_perl_script('Makefile.PL'); }); ok $result, "Makefile.PL ran without error"; @@ -167,7 +171,7 @@ ok $mb, "Module::Build->new_from_context"; my $libdir = File::Spec->catdir( $tmp, 'libdir' ); my $result; - stdout_of( sub { + stdout_stderr_of( sub { $result = $mb->run_perl_script('Makefile.PL', [], [ "LIB=$libdir", @@ -188,7 +192,7 @@ ok $mb, "Module::Build->new_from_context"; # Make sure those switches actually had an effect my ($ran_ok, $output); - $output = stdout_of( sub { $ran_ok = $new_build->do_system(@make, 'test') } ); + $output = stdout_stderr_of( sub { $ran_ok = $new_build->do_system(@make, 'test') } ); ok $ran_ok, "make test ran without error"; $output =~ s/^/# /gm; # Don't confuse our own test output like $output, qr/(?:# ok \d+\s+)+/, 'Should be verbose'; @@ -201,7 +205,7 @@ ok $mb, "Module::Build->new_from_context"; $make_macro = '/macro=("' . $make_macro . '")'; } - $output = stdout_of( sub { + $output = stdout_stderr_of( sub { local $ENV{HARNESS_TIMER}; # RT#39635 - timer messes with output $ran_ok = $mb->do_system(@make, 'test', $make_macro) } ); @@ -258,7 +262,7 @@ ok $mb, "Module::Build->new_from_context"; } } - stdout_of( sub { $mb->do_system(@make, 'realclean'); } ); + stdout_stderr_of( sub { $mb->do_system(@make, 'realclean'); } ); ok ! -e $makefile, "$makefile shouldn't exist"; 1 while unlink 'Makefile.PL'; @@ -274,14 +278,14 @@ ok $mb, "Module::Build->new_from_context"; create_makefile_pl('passthrough', $mb); - stdout_of( sub { + stdout_stderr_of( sub { $mb->run_perl_script('Makefile.PL', [], ['INSTALL_BASE=~/foo']); }); my $b2 = Module::Build->current; ok $b2->install_base, "install_base set"; unlike $b2->install_base, qr/^~/, "Tildes should be expanded"; - stdout_of( sub { $mb->do_system(@make, 'realclean'); } ); + stdout_stderr_of( sub { $mb->do_system(@make, 'realclean'); } ); ok ! -e $makefile, "$makefile shouldn't exist"; 1 while unlink 'Makefile.PL'; @@ -293,34 +297,53 @@ ok $mb, "Module::Build->new_from_context"; $dist->regen; my $mb; - stdout_of( sub { + stdout_stderr_of( sub { $mb = Module::Build->new_from_context( recursive_test_files => 1 ); }); create_makefile_pl('traditional', $mb); my $args = extract_writemakefile_args() || {}; - is $args->{TESTS}, - join( q{ }, - File::Spec->catfile(qw(t *.t)), - File::Spec->catfile(qw(t deep *.t)) - ), - 'Makefile.PL has correct TESTS line for recursive test files'; -} -# cleanup -$dist->remove; + if ( exists $args->{test}->{TESTS} ) { + is $args->{test}->{TESTS}, + join( q{ }, + File::Spec->catfile(qw(t *.t)), + File::Spec->catfile(qw(t deep *.t)) + ), + 'Makefile.PL has correct TESTS line for recursive test files'; + } else { + ok( ! exists $args->{TESTS}, 'Not using incorrect recursive tests key' ); + } + +} ######################################################### +sub _merge_prereqs { + my ($first, $second) = @_; + my $new = { %$first }; + for my $k (keys %$second) { + if ( exists $new->{$k} ) { + my ($v1,$v2) = ($new->{$k},$second->{$k}); + $new->{$k} = ($v1 > $v2 ? $v1 : $v2); + } + else { + $new->{$k} = $second->{$k}; + } + } + return $new; +} + sub test_makefile_types { my %opts = @_; $opts{requires} ||= {}; + $opts{build_requires} ||= {}; $opts{PL_files} ||= {}; foreach my $type (@makefile_types) { # Create M::B instance my $mb; - stdout_of( sub { + stdout_stderr_of( sub { $mb = Module::Build->new_from_context; }); ok $mb, "Module::Build->new_from_context"; @@ -330,12 +353,12 @@ sub test_makefile_types { test_makefile_pl_requires_perl( $opts{requires}{perl} ); test_makefile_creation($mb); - test_makefile_prereq_pm( $opts{requires} ); + test_makefile_prereq_pm( _merge_prereqs($opts{requires}, $opts{build_requires}) ); test_makefile_pl_files( $opts{PL_files} ) if $type eq 'traditional'; my ($output,$success); # Capture output to keep our STDOUT clean - $output = stdout_of( sub { + $output = stdout_stderr_of( sub { $success = $mb->do_system(@make); }); ok $success, "make ran without error"; @@ -345,13 +368,13 @@ sub test_makefile_types { } # Can't let 'test' STDOUT go to our STDOUT, or it'll confuse Test::Harness. - $output = stdout_of( sub { + $output = stdout_stderr_of( sub { $success = $mb->do_system(@make, 'test'); }); ok $success, "make test ran without error"; like uc $output, qr{DONE\.|SUCCESS}, "make test output indicated success"; - $output = stdout_of( sub { + $output = stdout_stderr_of( sub { $success = $mb->do_system(@make, 'realclean'); }); ok $success, "make realclean ran without error"; @@ -372,7 +395,7 @@ sub test_makefile_creation { my ($output, $result); # capture output to avoid polluting our test output - $output = stdout_of( sub { + $output = stdout_stderr_of( sub { $result = $build->run_perl_script('Makefile.PL', $preargs, $postargs); }); my $label = "Makefile.PL ran without error"; @@ -472,7 +495,8 @@ sub extract_writemakefile_args { } sub create_makefile_pl { - Module::Build::Compat->create_makefile_pl(@_); + my @args = @_; + stdout_stderr_of( sub { Module::Build::Compat->create_makefile_pl(@args) } ); my $ok = ok -e 'Makefile.PL', "$_[0] Makefile.PL created"; # Some really conservative make's, like HP/UX, assume files with the same diff --git a/cpan/Module-Build/t/compat/exit.t b/cpan/Module-Build/t/compat/exit.t index 78269a97a3..3672c938c3 100644..100755 --- a/cpan/Module-Build/t/compat/exit.t +++ b/cpan/Module-Build/t/compat/exit.t @@ -3,10 +3,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 5; +use MBTest tests => 3; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); ######################### @@ -24,11 +23,13 @@ $dist->chdir_in; my $mb; stdout_of(sub{ $mb = Module::Build->new_from_context}); -use Module::Build::Compat; +blib_load('Module::Build::Compat'); $dist->regen; -Module::Build::Compat->create_makefile_pl('passthrough', $mb); +stdout_stderr_of( + sub{ Module::Build::Compat->create_makefile_pl('passthrough', $mb); } +); # as silly as all of this exit(0) business is, that is what the cpan # testers have instructed everybody to do so... diff --git a/cpan/Module-Build/t/debug.t b/cpan/Module-Build/t/debug.t index c9b4fa581c..e0b8f60817 100644 --- a/cpan/Module-Build/t/debug.t +++ b/cpan/Module-Build/t/debug.t @@ -2,18 +2,15 @@ use strict; use lib 't/lib'; -use MBTest tests => 3; +use MBTest tests => 1; -require_ok('Module::Build'); -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; use DistGen; my $dist = DistGen->new( dir => $tmp ); $dist->regen; -END{ $dist->remove } - $dist->chdir_in; ######################### @@ -28,6 +25,3 @@ $dist->chdir_in; ); } -######################### - -# cleanup diff --git a/cpan/Module-Build/t/destinations.t b/cpan/Module-Build/t/destinations.t index 4af99d0031..07247a32ba 100644 --- a/cpan/Module-Build/t/destinations.t +++ b/cpan/Module-Build/t/destinations.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 115; +use MBTest tests => 113; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; @@ -248,7 +247,8 @@ $mb->prefix(undef); } # Poke at the innards of MB to change the default install locations. - my $old = $mb->install_sets->{site} = \%test_config; + my $old = $mb->install_sets->{site}; + $mb->install_sets->{site} = \%test_config; $mb->config(siteprefixexp => catdir(File::Spec->rootdir, 'wierd', 'prefix')); @@ -321,5 +321,3 @@ sub test_install_destinations { } } - -$dist->remove; diff --git a/cpan/Module-Build/t/ext.t b/cpan/Module-Build/t/ext.t index 8045761c2a..6101bccd16 100644 --- a/cpan/Module-Build/t/ext.t +++ b/cpan/Module-Build/t/ext.t @@ -4,8 +4,6 @@ use strict; use lib 't/lib'; use MBTest; -use Module::Build; - my @unix_splits = ( { q{one t'wo th'ree f"o\"ur " "five" } => [ 'one', 'two three', 'fo"ur ', 'five' ] }, @@ -58,9 +56,11 @@ my @win_splits = { 'a " b " c' => [ 'a', ' b ', 'c' ] }, ); -plan tests => 10 + 4*@unix_splits + 4*@win_splits; +plan tests => 9 + 4*@unix_splits + 4*@win_splits; -ensure_blib('Module::Build'); +blib_load('Module::Build'); +blib_load('Module::Build::Platform::Unix'); +blib_load('Module::Build::Platform::Windows'); ######################### @@ -74,7 +74,6 @@ foreach my $platform ('', '::Platform::Unix', '::Platform::Windows') { # I think 3.24 isn't actually the majik version, my 3.23 seems to pass... my $low_TPW_version = Text::ParseWords->VERSION < 3.24; -use Module::Build::Platform::Unix; foreach my $test (@unix_splits) { # Text::ParseWords bug: local $TODO = $low_TPW_version && ((keys %$test)[0] =~ m{\\\n}); @@ -82,7 +81,6 @@ foreach my $test (@unix_splits) { do_split_tests('Module::Build::Platform::Unix', $test); } -use Module::Build::Platform::Windows; foreach my $test (@win_splits) { do_split_tests('Module::Build::Platform::Windows', $test); } diff --git a/cpan/Module-Build/t/extend.t b/cpan/Module-Build/t/extend.t index db99eec70b..36ff4b6946 100644 --- a/cpan/Module-Build/t/extend.t +++ b/cpan/Module-Build/t/extend.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 66; +use MBTest tests => 64; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; @@ -79,7 +78,7 @@ print "Hello, World!\n"; $mb->add_build_element('foo'); $mb->add_build_element('foo'); - is_deeply $mb->build_elements, [qw(PL support pm xs pod script foo)], + is_deeply $mb->build_elements, [qw(PL support pm xs share_dir pod script foo)], 'The foo element should be in build_elements only once'; $mb->dispatch('build'); @@ -187,21 +186,20 @@ print "Hello, World!\n"; meta_add => {foo => 'bar'}, conflicts => {'Foo::Barxx' => 0}, ); - my %data; - $mb->prepare_metadata( \%data ); - is $data{foo}, 'bar'; + my $data = $mb->prepare_metadata; + is $data->{foo}, 'bar'; $mb->meta_merge(foo => 'baz'); - $mb->prepare_metadata( \%data ); - is $data{foo}, 'baz'; + $data = $mb->prepare_metadata; + is $data->{foo}, 'baz'; $mb->meta_merge(conflicts => {'Foo::Fooxx' => 0}); - $mb->prepare_metadata( \%data ); - is_deeply $data{conflicts}, {'Foo::Barxx' => 0, 'Foo::Fooxx' => 0}; + $data = $mb->prepare_metadata; + is_deeply $data->{conflicts}, {'Foo::Barxx' => 0, 'Foo::Fooxx' => 0}; $mb->meta_add(conflicts => {'Foo::Bazxx' => 0}); - $mb->prepare_metadata( \%data ); - is_deeply $data{conflicts}, {'Foo::Bazxx' => 0, 'Foo::Fooxx' => 0}; + $data = $mb->prepare_metadata; + is_deeply $data->{conflicts}, {'Foo::Bazxx' => 0, 'Foo::Fooxx' => 0}; } { @@ -275,5 +273,3 @@ print "Hello, World!\n"; } -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/files.t b/cpan/Module-Build/t/files.t index 87b192eaba..cf822fb091 100644 --- a/cpan/Module-Build/t/files.t +++ b/cpan/Module-Build/t/files.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 6; +use MBTest tests => 4; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); use IO::File; my $tmp = MBTest->tmpdir; @@ -46,5 +45,3 @@ my $mb = Module::Build->new_from_context; ok( Module::Build->dir_contains($first, $second) ); } -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/help.t b/cpan/Module-Build/t/help.t index 8408315f07..2bf34c8d50 100644 --- a/cpan/Module-Build/t/help.t +++ b/cpan/Module-Build/t/help.t @@ -2,38 +2,23 @@ use strict; use lib 't/lib'; -use MBTest tests => 25; +use MBTest tests => 23; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); - -use Cwd (); -use File::Path (); - -my $cwd = Cwd::cwd(); -my $tmp = MBTest->tmpdir; +blib_load('Module::Build'); use DistGen; -my $dist = DistGen->new(dir => $tmp); - - +my $dist = DistGen->new; $dist->regen; +$dist->chdir_in; my $restart = sub { - $dist->clean(); - DistGen::chdir_all( $cwd ); - File::Path::rmtree( $tmp ); # we're redefining the same package as we go, so... delete($::{'MyModuleBuilder::'}); delete($INC{'MyModuleBuilder.pm'}); - $dist->regen; - chdir($dist->dirname) or - die "Can't chdir to '@{[$dist->dirname]}': $!"; + $dist->regen( clean => 1 ); }; -chdir($dist->dirname) or die "Can't chdir to '@{[$dist->dirname]}': $!"; - ######################################################################## { # check the =item style my $mb = Module::Build->subclass( @@ -274,7 +259,5 @@ is($mb->get_action_docs('batz'), undef, 'nothing after uplevel'); # cleanup $dist->clean(); -DistGen::chdir_all($cwd); -File::Path::rmtree( $tmp ); # vim:ts=2:sw=2:et:sta diff --git a/cpan/Module-Build/t/install.t b/cpan/Module-Build/t/install.t index 2cadaa39da..66cdd5c94a 100644 --- a/cpan/Module-Build/t/install.t +++ b/cpan/Module-Build/t/install.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 36; +use MBTest tests => 34; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); use Config; use Cwd (); @@ -225,10 +224,7 @@ Simple Man <simple@example.com> is keys %$pms, 0; # revert to pristine state - $dist->remove; - $dist = DistGen->new( dir => $tmp ); - $dist->regen; - $dist->chdir_in; + $dist->regen( clean => 1 ); } sub strip_volume { @@ -243,6 +239,3 @@ sub file_exists { ok -e $file or diag("Expected $file to exist, but it doesn't"); } - -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/install_extra_target.t b/cpan/Module-Build/t/install_extra_target.t index c717ce5eee..21d0c272ae 100644 --- a/cpan/Module-Build/t/install_extra_target.t +++ b/cpan/Module-Build/t/install_extra_target.t @@ -3,10 +3,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 8; +use MBTest tests => 6; -require_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); use File::Spec::Functions qw( catdir ); @@ -46,11 +45,11 @@ sub process_etc_files } #Copy share files to blib -sub process_share_files +sub process_shared_files { my $self = shift; - $self->copy_files("share"); + $self->copy_files("shared"); } 1; @@ -62,23 +61,23 @@ my $build = $subclass->new( ); $build->add_build_element('etc'); -$build->add_build_element('share'); +$build->add_build_element('shared'); my $distdir = lc $build->dist_name(); foreach my $id ('core', 'site', 'vendor') { #Where to install these build types when using prefix symantics - $build->prefix_relpaths($id, 'share' => "share/$distdir"); + $build->prefix_relpaths($id, 'shared' => "shared/$distdir"); $build->prefix_relpaths($id, 'etc' => "etc/$distdir"); #Where to install these build types when using default symantics my $set = $build->install_sets($id); - $set->{'share'} = '/usr/'.($id eq 'site' ? 'local/':'')."share/$distdir"; + $set->{'shared'} = '/usr/'.($id eq 'site' ? 'local/':'')."shared/$distdir"; $set->{'etc'} = ($id eq 'site' ? '/usr/local/etc/':'/etc/').$distdir; } #Where to install these types when using install_base symantics -$build->install_base_relpaths('share' => "share/$distdir"); +$build->install_base_relpaths('shared' => "shared/$distdir"); $build->install_base_relpaths('etc' => "etc/$distdir"); $build->create_build_script(); @@ -97,12 +96,12 @@ stardate = 1234344 ===EOF=== -$dist->add_file("share/data", <<'===EOF==='); +$dist->add_file("shared/data", <<'===EOF==='); 7 * 9 = 42? ===EOF=== -$dist->add_file("share/html/index.html", <<'===EOF==='); +$dist->add_file("shared/html/index.html", <<'===EOF==='); <HTML> <BODY> <H1>Hello World!</H1> @@ -122,16 +121,15 @@ $output .= stdout_of sub { $dist->run_build }; my $error; $error++ unless ok(-e "blib/etc/config", "Built etc/config"); -$error++ unless ok(-e "blib/share/data", "Built share/data"); -$error++ unless ok(-e "blib/share/html/index.html", "Built share/html"); +$error++ unless ok(-e "blib/shared/data", "Built shared/data"); +$error++ unless ok(-e "blib/shared/html/index.html", "Built shared/html"); diag "OUTPUT:\n$output" if $error; $output = stdout_of sub { $dist->run_build('install') }; $error = 0; $error++ unless ok(-e "$installdest/etc/simple/config", "installed etc/config"); -$error++ unless ok(-e "$installdest/share/simple/data", "installed share/data"); -$error++ unless ok(-e "$installdest/share/simple/html/index.html", "installed share/html"); +$error++ unless ok(-e "$installdest/shared/simple/data", "installed shared/data"); +$error++ unless ok(-e "$installdest/shared/simple/html/index.html", "installed shared/html"); diag "OUTPUT:\n$output" if $error; -$dist->remove(); diff --git a/cpan/Module-Build/t/lib/DistGen.pm b/cpan/Module-Build/t/lib/DistGen.pm index 86ee794f3b..d1fb260d60 100644 --- a/cpan/Module-Build/t/lib/DistGen.pm +++ b/cpan/Module-Build/t/lib/DistGen.pm @@ -7,9 +7,9 @@ use vars qw( $VERSION $VERBOSE @EXPORT_OK); $VERSION = '0.01'; $VERBOSE = 0; - use Carp; +use MBTest (); use Cwd (); use File::Basename (); use File::Find (); @@ -38,7 +38,7 @@ BEGIN { $vms_efs_case = VMS::Feature::current("efs_case_preserve"); } else { my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; $vms_efs_case = $efs_case =~ /^[ET1]/i; } @@ -64,44 +64,76 @@ sub undent { } sub chdir_all ($) { - # OS/2 has "current directory per disk", undeletable; + # OS/2 has "current directory per disk", undeletable; # doing chdir() to another disk won't change cur-dir of initial disk... chdir('/') if $^O eq 'os2'; chdir shift; } + ######################################################################## +END { chdir_all(MBTest->original_cwd); } + sub new { - my $package = shift; + my $self = bless {}, shift; + $self->reset(@_); +} + +sub reset { + my $self = shift; my %options = @_; $options{name} ||= 'Simple'; - $options{dir} ||= Cwd::cwd(); + $options{dir} = File::Spec->rel2abs( + defined $options{dir} ? $options{dir} : MBTest->tmpdir + ); my %data = ( no_manifest => 0, xs => 0, + inc => 0, %options, ); - my $self = bless( \%data, $package ); - - # So we can clean up later even if the caller chdir()s - $self->{dir} = File::Spec->rel2abs($self->{dir}); + %$self = %data; tie %{$self->{filedata}}, 'Tie::CPHash'; tie %{$self->{pending}{change}}, 'Tie::CPHash'; + # start with a fresh, empty directory if ( -d $self->dirname ) { warn "Warning: Removing existing directory '@{[$self->dirname]}'\n"; - $self->remove; + File::Path::rmtree( $self->dirname ); } + File::Path::mkpath( $self->dirname ); $self->_gen_default_filedata(); return $self; } +sub remove { + my $self = shift; + $self->chdir_original if($self->did_chdir); + File::Path::rmtree( $self->dirname ); + return $self; +} + +sub revert { + my ($self, $file) = @_; + if ( defined $file ) { + delete $self->{filedata}{$file}; + delete $self->{pending}{$_}{$file} for qw/change remove/; + } + else { + delete $self->{filedata}{$_} for keys %{ $self->{filedata} }; + for my $pend ( qw/change remove/ ) { + delete $self->{pending}{$pend}{$_} for keys %{ $self->{pending}{$pend} }; + } + } + $self->_gen_default_filedata; +} + sub _gen_default_filedata { my $self = shift; @@ -112,17 +144,32 @@ sub _gen_default_filedata { $self->add_file($member, $data) unless($self->{filedata}{$member}); }; - $self->$add_unless('Build.PL', undent(<<" ---")); - use strict; - use Module::Build; + if ( ! $self->{inc} ) { + $self->$add_unless('Build.PL', undent(<<" ---")); + use strict; + use Module::Build; - my \$builder = Module::Build->new( - module_name => '$self->{name}', - license => 'perl', - ); + my \$builder = Module::Build->new( + module_name => '$self->{name}', + license => 'perl', + ); - \$builder->create_build_script(); - --- + \$builder->create_build_script(); + --- + } + else { + $self->$add_unless('Build.PL', undent(<<" ---")); + use strict; + use inc::latest 'Module::Build'; + + my \$builder = Module::Build->new( + module_name => '$self->{name}', + license => 'perl', + ); + + \$builder->create_build_script(); + --- + } my $module_filename = join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm'; @@ -229,7 +276,7 @@ sub _gen_default_filedata { # 5.6 is missing const char * in its typemap $self->$add_unless('typemap', undent(<<" ---")); - const char * T_PV + const char *\tT_PV --- $self->$add_unless('t/basic.t', undent(<<" ---")); @@ -249,7 +296,6 @@ sub _gen_manifest { my $manifest = shift; my $fh = IO::File->new( ">$manifest" ) or do { - $self->remove(); die "Can't write '$manifest'\n"; }; @@ -312,7 +358,6 @@ sub regen { my $dirname = File::Basename::dirname( $fullname ); unless ( -d $dirname ) { File::Path::mkpath( $dirname ) or do { - $self->remove(); die "Can't create '$dirname'\n"; }; } @@ -322,7 +367,6 @@ sub regen { } my $fh = IO::File->new(">$fullname") or do { - $self->remove(); die "Can't write '$fullname'\n"; }; print $fh $self->{filedata}{$file}; @@ -339,6 +383,7 @@ sub regen { } $self->_gen_manifest( $manifest ); } + return $self; } sub clean { @@ -396,20 +441,7 @@ sub clean { }, ($^O eq 'VMS' ? './' : File::Spec->curdir) ); chdir_all( $here ); -} - -sub remove { - my $self = shift; - croak("invalid usage -- remove()") if(@_); - $self->chdir_original if($self->did_chdir); - File::Path::rmtree( $self->dirname ); - # might as well check - croak("\nthis test should have used chdir_in()") unless(Cwd::getcwd); -} - -sub revert { - my $self = shift; - die "Unimplemented.\n"; + return $self; } sub add_file { @@ -425,10 +457,13 @@ sub remove_file { } delete( $self->{filedata}{$file} ); $self->{pending}{remove}{$file} = 1; + return $self; } sub change_build_pl { - my ($self, $opts) = @_; + my ($self, @opts) = @_; + + my $opts = ref $opts[0] eq 'HASH' ? $opts[0] : { @opts }; local $Data::Dumper::Terse = 1; (my $args = Dumper($opts)) =~ s/^\s*\{|\}\s*$//g; @@ -437,16 +472,17 @@ sub change_build_pl { use strict; use Module::Build; my \$b = Module::Build->new( - # Some CPANPLUS::Dist::Build versions need to allow mismatches + # Some CPANPLUS::Dist::Build versions need to allow mismatches # On logic: thanks to Module::Install, CPAN.pm must set both keys, but # CPANPLUS sets only the one - allow_mb_mismatch => ( + allow_mb_mismatch => ( \$ENV{PERL5_CPANPLUS_IS_RUNNING} && ! \$ENV{PERL5_CPAN_IS_RUNNING} ? 1 : 0 ), $args ); \$b->create_build_script(); --- + return $self; } sub change_file { @@ -455,6 +491,7 @@ sub change_file { my $data = shift; $self->{filedata}{$file} = $data; $self->{pending}{change}{$file} = 1; + return $self; } sub get_file { @@ -466,40 +503,43 @@ sub get_file { sub chdir_in { my $self = shift; - - $self->{original_dir} ||= Cwd::cwd; # only once + $self->{original_dir} ||= Cwd::cwd; # only once! my $dir = $self->dirname; chdir($dir) or die "Can't chdir to '$dir': $!"; + return $self; } ######################################################################## -sub did_chdir { - my $self = shift; +sub did_chdir { exists shift()->{original_dir} } - return exists($self->{original_dir}); -} ######################################################################## sub chdir_original { my $self = shift; - croak("never called chdir_in()") unless($self->{original_dir}); - my $dir = $self->{original_dir}; + my $dir = delete $self->{original_dir}; chdir_all($dir) or die "Can't chdir to '$dir': $!"; + return $self; } ######################################################################## +sub new_from_context { + my ($self, @args) = @_; + require Module::Build; + return Module::Build->new_from_context( quiet => 1, @args ); +} + sub run_build_pl { my ($self, @args) = @_; require Module::Build; - Module::Build->run_perl_script('Build.PL', [], [@args]) + return Module::Build->run_perl_script('Build.PL', [], [@args]) } sub run_build { my ($self, @args) = @_; require Module::Build; my $build_script = $^O eq 'VMS' ? 'Build.com' : 'Build'; - Module::Build->run_perl_script($build_script, [], [@args]) + return Module::Build->run_perl_script($build_script, [], [@args]) } 1; @@ -516,8 +556,7 @@ DistGen - Creates simple distributions for testing. use DistGen; # create distribution and prepare to test - my $dist = DistGen->new(name => 'Foo::Bar', dir => $tmp); - $dist->regen; + my $dist = DistGen->new(name => 'Foo::Bar'); $dist->chdir_in; # change distribution files @@ -526,42 +565,48 @@ DistGen - Creates simple distributions for testing. $dist->remove_file('t/some_test.t'); $dist->regen; - # clean up extraneous files + # undo changes and clean up extraneous files + $dist->revert; $dist->clean; # exercise the command-line interface $dist->run_build_pl(); $dist->run_build('test'); - # finish testing and clean up - $dist->chdir_original; - $dist->remove; + # start over as a new distribution + $dist->reset( name => 'Foo::Bar', xs => 1 ); + $dist->chdir_in; =head1 USAGE A DistGen object manages a set of files in a distribution directory. -The constructor and some methods only define the target state of the -distribution. They do B<not> make any changes to the filesystem: +The C<new()> constructor initializes the object and creates an empty +directory for the distribution. It does not create files or chdir into +the directory. The C<reset()> method re-initializes the object in a +new directory with new parameters. It also does not create files or change +the current directory. + +Some methods only define the target state of the distribution. They do B<not> +make any changes to the filesystem: - new add_file change_file change_build_pl remove_file + revert Other methods then change the filesystem to match the target state of -the distribution (or to remove it entirely): +the distribution: - regen clean + regen remove Other methods are provided for a convenience during testing. The -most important are ones that manage the current directory: +most important is the one to enter the distribution directory: chdir_in - chdir_original Additional methods portably encapsulate running Build.PL and Build: @@ -570,16 +615,19 @@ Additional methods portably encapsulate running Build.PL and Build: =head1 API -=head2 Constructor +=head2 Constructors =head3 new() -Create a new object. Does not write its contents (see L</regen()>.) +Create a new object and an empty directory to hold the distribution's files. +If no C<dir> option is provided, it defaults to MBTest->tmpdir, which sets +a different temp directory for Perl core testing and CPAN testing. + +The C<new> method does not write any files -- see L</regen()> below. - my $tmp = MBTest->tmpdir; my $dist = DistGen->new( name => 'Foo::Bar', - dir => $tmp, + dir => MBTest->tmpdir, xs => 1, no_manifest => 0, ); @@ -596,9 +644,14 @@ dist name. =item dir -The (parent) directory in which to create the distribution directory. -The default is File::Spec->curdir. The distribution will be created -under this according to the "dist" form of C<name> (e.g. "Foo-Bar".) +The (parent) directory in which to create the distribution directory. The +distribution will be created under this according to the "dist" form of C<name> +(e.g. "Foo-Bar".) Defaults to a temporary directory. + + $dist = DistGen->new( dir => '/tmp/MB-test' ); + $dist->regen; + + # distribution files have been created in /tmp/MB-test/Simple =item xs @@ -622,6 +675,13 @@ the following files are also added: typemap lib/Simple.xs # based on name parameter +=head3 reset() + +The C<reset> method re-initializes the object as if it were generated +from a fresh call to C<new>. It takes the same optional parameters as C<new>. + + $dist->reset( name => 'Foo::Bar', xs => 0 ); + =head2 Adding and editing files Note that C<$filename> should always be specified with unix-style paths, @@ -669,6 +729,14 @@ Removes C<$filename> from the distribution. $dist->remove_file( $filename ); +=head3 revert() + +Returns the object to its initial state, or given a $filename it returns that +file to its initial state if it is one of the built-in files. + + $dist->revert; + $dist->revert($filename); + =head2 Changing the distribution directory These methods immediately affect the filesystem. @@ -680,8 +748,10 @@ flagged for removal with remove_file(). $dist->regen(clean => 1); -If the optional C<clean> argument is given, it also removes any -extraneous files that do not belong to the distribution. +If the optional C<clean> argument is given, it also calls C<clean>. These +can also be chained like this, instead: + + $dist->clean->regen; =head3 clean() @@ -689,22 +759,19 @@ Removes any files that are not part of the distribution. $dist->clean; -=begin TODO - -=head3 revert() - -[Unimplemented] Returns the object to its initial state, or given a -$filename it returns that file to it's initial state if it is one of -the built-in files. +=head3 remove() - $dist->revert; - $dist->revert($filename); +Changes back to the original directory and removes the distribution +directory (but not the temporary directory set during C<new()>). -=end TODO + $dist = DistGen->new->chdir->regen; + # ... do some testing ... -=head3 remove() + $dist->remove->chdir_in->regen; + # ... do more testing ... -Removes the entire distribution directory. +This is like a more aggressive form of C<clean>. Generally, calling C<clean> +and C<regen> should be sufficient. =head2 Changing directories diff --git a/cpan/Module-Build/t/lib/MBTest.pm b/cpan/Module-Build/t/lib/MBTest.pm index dc2410b399..11d02dec14 100644 --- a/cpan/Module-Build/t/lib/MBTest.pm +++ b/cpan/Module-Build/t/lib/MBTest.pm @@ -13,6 +13,7 @@ BEGIN { my @delete_env_keys = qw( DEVEL_COVER_OPTIONS MODULEBUILDRC + PERL_MB_OPT HARNESS_TIMER HARNESS_OPTIONS HARNESS_VERBOSE @@ -49,7 +50,15 @@ BEGIN { # In case the test wants to use our other bundled # modules, make sure they can be loaded. - push @INC, File::Spec->catdir('t', 'bundled'); + my $t_lib = File::Spec->catdir('t', 'bundled'); + push @INC, $t_lib; # Let user's installed version override + + if ($ENV{PERL_CORE}) { + # We change directories, so expand @INC and $^X to absolute paths + # Also add . + @INC = (map(File::Spec->rel2abs($_), @INC), "."); + $^X = File::Spec->rel2abs($^X); + } } use Exporter; @@ -74,7 +83,7 @@ my @extra_exports = qw( find_in_path check_compiler have_module - ensure_blib + blib_load ); push @EXPORT, @extra_exports; __PACKAGE__->export(scalar caller, @extra_exports); @@ -84,8 +93,10 @@ __PACKAGE__->export(scalar caller, @extra_exports); ######################################################################## # always return to the current directory -{ - my $cwd = Cwd::cwd; +{ + my $cwd = File::Spec->rel2abs(Cwd::cwd); + + sub original_cwd { return $cwd } END { # Go back to where you came from! @@ -103,13 +114,11 @@ __PACKAGE__->export(scalar caller, @extra_exports); } ######################################################################## -# Setup a temp directory -sub tmpdir { - my ($self, $usr_tmp) = @_; - return File::Temp::tempdir( 'MB-XXXXXXXX', - CLEANUP => 1, DIR => $ENV{PERL_CORE} ? Cwd::cwd : - $usr_tmp ? $usr_tmp : File::Spec->tmpdir - ); +# Setup a temp directory +sub tmpdir { + my ($self, @args) = @_; + my $dir = $ENV{PERL_CORE} ? MBTest->original_cwd : File::Spec->tmpdir; + return File::Temp::tempdir('MB-XXXXXXXX', CLEANUP => 1, DIR => $dir, @args); } sub save_handle { @@ -137,7 +146,7 @@ sub stdout_stderr_of { $stdout = stdout_of ( sub { $stderr = stderr_of( $subr ) }); - return ($stdout, $stderr); + return wantarray ? ($stdout, $stderr) : $stdout . $stderr; } sub slurp { @@ -160,24 +169,31 @@ sub exe_exts { sub find_in_path { my $thing = shift; - - my @path = split $Config{path_sep}, $ENV{PATH}; + my @exe_ext = exe_exts(); - foreach (@path) { - my $fullpath = File::Spec->catfile($_, $thing); + if ( File::Spec->file_name_is_absolute( $thing ) ) { foreach my $ext ( '', @exe_ext ) { - return "$fullpath$ext" if -e "$fullpath$ext"; + return "$thing$ext" if -e "$thing$ext"; + } + } + else { + my @path = split $Config{path_sep}, $ENV{PATH}; + foreach (@path) { + my $fullpath = File::Spec->catfile($_, $thing); + foreach my $ext ( '', @exe_ext ) { + return "$fullpath$ext" if -e "$fullpath$ext"; + } } } return; } -# returns ($have_c_compiler, $C_support_feature); sub check_compiler { return (1,1) if $ENV{PERL_CORE}; local $SIG{__WARN__} = sub {}; + blib_load('Module::Build'); my $mb = Module::Build->current; $mb->verbose( 0 ); @@ -197,26 +213,28 @@ sub check_compiler { ); $tmp_exec = 0 == system( $exe ); } - return ($have_c_compiler, $mb->feature('C_support'), $tmp_exec); + return ($have_c_compiler, $tmp_exec); } sub have_module { my $module = shift; - return eval "use $module; 1"; + return eval "require $module; 1"; } -sub ensure_blib { - # Make sure the given module was loaded from blib/, not the larger system +sub blib_load { + # Load the given module and ensure it came from blib/, not the larger system my $mod = shift; + have_module($mod) or die "Error loading $mod\: $@\n"; + (my $path = $mod) =~ s{::}{/}g; - - local $Test::Builder::Level = $Test::Builder::Level + 1; - SKIP: { - skip "no blib in core", 1 if $ENV{PERL_CORE}; - like $INC{"$path.pm"}, qr/\bblib\b/, "Make sure $mod was loaded from blib/" - or diag "PERL5LIB: " . ($ENV{PERL5LIB} || '') . "\n" . - "PERL5OPT: " . ($ENV{PERL5OPT} || '') . "\n" . - "\@INC contains:\n " . join("\n ", @INC) . "\n"; + $path .= ".pm"; + my ($pkg, $file, $line) = caller; + unless($ENV{PERL_CORE}) { + unless($INC{$path} =~ m/\bblib\b/) { + (my $load_from = $INC{$path}) =~ s{$path$}{}; + die "$mod loaded from '$load_from'\nIt should have been loaded from blib. \@INC contains:\n ", + join("\n ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n"; + } } } diff --git a/cpan/Module-Build/t/manifypods.t b/cpan/Module-Build/t/manifypods.t index 31c9e8ea83..5947646d13 100644 --- a/cpan/Module-Build/t/manifypods.t +++ b/cpan/Module-Build/t/manifypods.t @@ -3,15 +3,14 @@ use strict; use lib 't/lib'; use MBTest; -use Module::Build; -use Module::Build::ConfigData; +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); if ( Module::Build::ConfigData->feature('manpage_support') ) { - plan tests => 22; + plan tests => 21; } else { plan skip_all => 'manpage_support feature is not enabled'; } -ensure_blib('Module::Build'); ######################### @@ -139,11 +138,7 @@ $mb->dispatch('realclean'); # revert to a pristine state -$dist->remove; -$dist = DistGen->new( dir => $tmp ); -$dist->regen; -$dist->chdir_in; - +$dist->regen( clean => 1 ); my $mb2 = Module::Build->new( module_name => $dist->name, @@ -163,6 +158,3 @@ foreach ('testcover', 'disttest') { unlike $docs, qr/\n=/, $docs; } - -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/mbyaml.t b/cpan/Module-Build/t/mbyaml.t deleted file mode 100644 index d2cb0d547f..0000000000 --- a/cpan/Module-Build/t/mbyaml.t +++ /dev/null @@ -1,262 +0,0 @@ -#!/usr/local/bin/perl -w - -use strict; -use lib 't/lib'; -use MBTest 'no_plan'; - -use_ok 'Module::Build::YAML'; -ensure_blib('Module::Build::YAML'); - -my ($dir); -$dir = "."; -$dir = "t" if (-d "t"); - -{ - my ($expected, $got, $var); - ########################################################## - # Test a typical-looking Module::Build structure (alphabetized) - ########################################################## - $var = { - 'resources' => { - 'license' => 'http://opensource.org/licenses/artistic-license.php' - }, - 'meta-spec' => { - 'version' => '1.2', - 'url' => 'http://module-build.sourceforge.net/META-spec-v1.2.html' - }, - 'generated_by' => 'Module::Build version 0.2709', - 'version' => '0.13', - 'name' => 'js-app', - 'dynamic_config' => '1', - 'author' => [ - '"Stephen Adkins" <spadkins@gmail.com>' - ], - 'license' => 'lgpl', - 'build_requires' => { - 'App::Build' => '0', - 'File::Spec' => '0', - 'Module::Build' => '0' - }, - 'provides' => { - 'JavaScript::App' => { - 'version' => '0', - 'file' => 'lib/JavaScript/App.pm' - } - }, - 'requires' => { - 'App::Options' => '0' - }, - 'abstract' => 'A framework for building dynamic widgets or full applications in Javascript' - }; - $expected = <<'EOF'; ---- -abstract: A framework for building dynamic widgets or full applications in Javascript -author: - - '"Stephen Adkins" <spadkins@gmail.com>' -build_requires: - App::Build: 0 - File::Spec: 0 - Module::Build: 0 -dynamic_config: 1 -generated_by: Module::Build version 0.2709 -license: lgpl -meta-spec: - url: http://module-build.sourceforge.net/META-spec-v1.2.html - version: 1.2 -name: js-app -provides: - JavaScript::App: - file: lib/JavaScript/App.pm - version: 0 -requires: - App::Options: 0 -resources: - license: http://opensource.org/licenses/artistic-license.php -version: 0.13 -EOF - $got = &Module::Build::YAML::Dump($var); - is($got, $expected, "Dump(): single deep hash"); - - ########################################################## - # Test a typical-looking Module::Build structure (ordered) - ########################################################## - $expected = <<'EOF'; ---- -name: js-app -version: 0.13 -author: - - '"Stephen Adkins" <spadkins@gmail.com>' -abstract: A framework for building dynamic widgets or full applications in Javascript -license: lgpl -resources: - license: http://opensource.org/licenses/artistic-license.php -requires: - App::Options: 0 -build_requires: - App::Build: 0 - File::Spec: 0 - Module::Build: 0 -dynamic_config: 1 -provides: - JavaScript::App: - file: lib/JavaScript/App.pm - version: 0 -generated_by: Module::Build version 0.2709 -meta-spec: - url: http://module-build.sourceforge.net/META-spec-v1.2.html - version: 1.2 -EOF - $var->{_order} = [qw(name version author abstract license resources requires build_requires dynamic_config provides)]; - $got = &Module::Build::YAML::Dump($var); - is($got, $expected, "Dump(): single deep hash, ordered"); - - ########################################################## - # Test that an array turns into multiple documents - ########################################################## - $var = [ - "e", - 2.71828, - [ "pi", "is", 3.1416 ], - { fun => "under_sun", 6 => undef, "more", undef }, - ]; - $expected = <<'EOF'; ---- -e ---- -2.71828 ---- -- pi -- is -- 3.1416 ---- -6: ~ -fun: under_sun -more: ~ -EOF - $got = &Module::Build::YAML::Dump(@$var); - is($got, $expected, "Dump(): multiple, various"); - - ########################################################## - # Test that a single array ref turns into one document - ########################################################## - $expected = <<'EOF'; ---- -- e -- 2.71828 -- - - pi - - is - - 3.1416 -- - 6: ~ - fun: under_sun - more: ~ -EOF - $got = &Module::Build::YAML::Dump($var); - is($got, $expected, "Dump(): single array of various"); - - ########################################################## - # Test Object-Oriented Flavor of the API - ########################################################## - my $y = Module::Build::YAML->new(); - $got = $y->Dump($var); - is($got, $expected, "Dump(): single array of various (OO)"); - - ########################################################## - # Test Quoting Conditions (newlines, quotes, tildas, undefs) - ########################################################## - $var = { - 'foo01' => '`~!@#$%^&*()_+-={}|[]\\;\':",./?<> -<nl>', - 'foo02' => '~!@#$%^&*()_+-={}|[]\\;:,./<>?', - 'foo03' => undef, - 'foo04' => '~', - }; - $expected = <<'EOF'; ---- -foo01: "`~!@#$%^&*()_+-={}|[]\;':\",./?<>\n<nl>" -foo02: "~!@#$%^&*()_+-={}|[]\;:,./<>?" -foo03: ~ -foo04: "~" -EOF - $got = &Module::Build::YAML::Dump($var); - is($got, $expected, "Dump(): tricky embedded characters"); - - $var = { - 'foo10' => undef, - 'foo40' => '!', - 'foo41' => '@', - 'foo42' => '#', - 'foo43' => '$', - 'foo44' => '%', - 'foo45' => '^', - 'foo47' => '&', - 'foo48' => '*', - 'foo49' => '(', - 'foo50' => ')', - 'foo51' => '_', - 'foo52' => '+', - 'foo53' => '-', - 'foo54' => '=', - 'foo55' => '{', - 'foo56' => '}', - 'foo57' => '|', - 'foo58' => '[', - 'foo59' => ']', - 'foo60' => '\\', - 'foo61' => ';', - 'foo62' => ':', - 'foo63' => ',', - 'foo64' => '.', - 'foo65' => '/', - 'foo66' => '<', - 'foo67' => '>', - 'foo68' => '?', - 'foo69' => '\'', - 'foo70' => '"', - 'foo71' => '`', - 'foo72' => ' -', - }; - $expected = <<'EOF'; ---- -foo10: ~ -foo40: "!" -foo41: '@' -foo42: "#" -foo43: $ -foo44: % -foo45: "^" -foo47: "&" -foo48: "*" -foo49: "(" -foo50: ")" -foo51: _ -foo52: + -foo53: - -foo54: = -foo55: "{" -foo56: "}" -foo57: "|" -foo58: "[" -foo59: "]" -foo60: \ -foo61: ; -foo62: : -foo63: , -foo64: . -foo65: / -foo66: '<' -foo67: '>' -foo68: "?" -foo69: "'" -foo70: '"' -foo71: "`" -foo72: "\n" -EOF - $got = &Module::Build::YAML::Dump($var); - is($got, $expected, "Dump(): tricky embedded characters (singles)"); - -} - - diff --git a/cpan/Module-Build/t/metadata.t b/cpan/Module-Build/t/metadata.t index 6f53c1d225..2850bea24c 100644 --- a/cpan/Module-Build/t/metadata.t +++ b/cpan/Module-Build/t/metadata.t @@ -2,15 +2,13 @@ use strict; use lib 't/lib'; -use MBTest tests => 53; +use MBTest tests => 51; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); my $tmp = MBTest->tmpdir; -use Module::Build::ConfigData; - my %metadata = ( module_name => 'Simple', @@ -56,7 +54,6 @@ my $simple2_file = 'lib/Simple2.pm'; $dist->chdir_in; -use Module::Build; my $mb = Module::Build->new_from_context; ################################################## @@ -68,7 +65,7 @@ my $mb = Module::Build->new_from_context; my $mb_config_req = { 'Module::Build' => int($Module::Build::VERSION * 100)/100 }; - my $node = $mb->prepare_metadata( {} ); + my $node = $mb->prepare_metadata( ); # exists() doesn't seem to work here is $node->{name}, $metadata{module_name}; @@ -89,7 +86,7 @@ my $mb = Module::Build->new_from_context; { my $mb_prereq = { 'Module::Build' => 0 }; $mb->configure_requires( $mb_prereq ); - my $node = $mb->prepare_metadata( {} ); + my $node = $mb->prepare_metadata( ); # exists() doesn't seem to work here @@ -366,7 +363,7 @@ package Simple; $VERSION = '2.34'; --- $dist->regen( clean => 1 ); -$mb = new_build(); +stderr_of( sub { $mb = new_build(); } ); $err = stderr_of( sub { $provides = $mb->find_dist_packages } ); is_deeply($provides, {'Simple' => { file => $simple_file, @@ -470,7 +467,7 @@ package Foo; $VERSION = '2.34'; --- $dist->regen( clean => 1 ); -$mb = new_build(); +stderr_of( sub { $mb = new_build(); } ); $err = stderr_of( sub { $provides = $mb->find_dist_packages } ); # XXX Should 'Foo' exist ??? Can't predict values for file & version ok( exists( $provides->{Foo} ) ); @@ -604,6 +601,3 @@ $dist->regen( clean => 1 ); $mb = new_build(); is_deeply($mb->find_dist_packages, {}); -############################################################ -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/metadata2.t b/cpan/Module-Build/t/metadata2.t index a5af034dc0..954b6589a0 100644 --- a/cpan/Module-Build/t/metadata2.t +++ b/cpan/Module-Build/t/metadata2.t @@ -2,14 +2,11 @@ use strict; use lib 't/lib'; -use MBTest tests => 20; +use MBTest tests => 18; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); -my $tmp = MBTest->tmpdir; - -use Module::Build::ConfigData; use DistGen; @@ -19,14 +16,12 @@ SKIP: { skip( 'YAML_support feature is not enabled', 4 ) unless Module::Build::ConfigData->feature('YAML_support'); - my $dist = DistGen->new( dir => $tmp, no_manifest => 1 ); - $dist->regen; - - $dist->chdir_in; + my $dist = DistGen->new( no_manifest => 1 )->chdir_in->regen; ok ! -e 'MANIFEST'; - my $mb = Module::Build->new_from_context; + my $mb; + stderr_of( sub { $mb = Module::Build->new_from_context } ); my $out; $out = eval { stderr_of(sub{$mb->dispatch('distmeta')}) }; @@ -36,7 +31,6 @@ SKIP: { ok -e 'META.yml'; - $dist->remove; } @@ -62,7 +56,7 @@ Simple Simon <simon@simple.sim> =cut --- -my $dist = DistGen->new( dir => $tmp ); +my $dist = DistGen->new->chdir_in; $dist->change_build_pl ({ @@ -71,10 +65,6 @@ $dist->change_build_pl license => 'perl', create_readme => 1, }); -$dist->regen; - -$dist->chdir_in; - # .pm File with pod # @@ -139,7 +129,3 @@ is( $mb->dist_author->[0], 'Simple Simon <simon@simple.sim>', is( $mb->dist_abstract, "A simple module", "Extracting abstract from .pod over .pm"); - -############################################################ -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/moduleinfo.t b/cpan/Module-Build/t/moduleinfo.t index ca7eb048e5..e28726d493 100644 --- a/cpan/Module-Build/t/moduleinfo.t +++ b/cpan/Module-Build/t/moduleinfo.t @@ -4,99 +4,58 @@ use strict; use lib 't/lib'; -use MBTest tests => 82; - -use_ok 'Module::Build::ModuleInfo'; -ensure_blib('Module::Build::ModuleInfo'); - -my $tmp = MBTest->tmpdir; - -use DistGen; -my $dist = DistGen->new( dir => $tmp ); -$dist->regen; - -$dist->chdir_in; - -######################### - -# class method C<find_module_by_name> -my $module = Module::Build::ModuleInfo->find_module_by_name( - 'Module::Build::ModuleInfo' ); -ok( -e $module, 'find_module_by_name() succeeds' ); - - -# fail on invalid module name -my $pm_info = Module::Build::ModuleInfo->new_from_module( - 'Foo::Bar', inc => [] ); -ok( !defined( $pm_info ), 'fail if can\'t find module by module name' ); - - -# fail on invalid filename -my $file = File::Spec->catfile( 'Foo', 'Bar.pm' ); -$pm_info = Module::Build::ModuleInfo->new_from_file( $file, inc => [] ); -ok( !defined( $pm_info ), 'fail if can\'t find module by file name' ); - - -# construct from module filename -$file = File::Spec->catfile( 'lib', split( /::/, $dist->name ) ) . '.pm'; -$pm_info = Module::Build::ModuleInfo->new_from_file( $file ); -ok( defined( $pm_info ), 'new_from_file() succeeds' ); - -# construct from module name, using custom include path -$pm_info = Module::Build::ModuleInfo->new_from_module( - $dist->name, inc => [ 'lib', @INC ] ); -ok( defined( $pm_info ), 'new_from_module() succeeds' ); - +use MBTest; # parse various module $VERSION lines +# these will be reversed later to create %modules my @modules = ( - <<'---', # declared & defined on same line with 'our' + '1.23' => <<'---', # declared & defined on same line with 'our' package Simple; our $VERSION = '1.23'; --- - <<'---', # declared & defined on separate lines with 'our' + '1.23' => <<'---', # declared & defined on separate lines with 'our' package Simple; our $VERSION; $VERSION = '1.23'; --- - <<'---', # use vars + '1.23' => <<'---', # use vars package Simple; use vars qw( $VERSION ); $VERSION = '1.23'; --- - <<'---', # choose the right default package based on package/file name + '1.23' => <<'---', # choose the right default package based on package/file name package Simple::_private; $VERSION = '0'; package Simple; $VERSION = '1.23'; # this should be chosen for version --- - <<'---', # just read the first $VERSION line + '1.23' => <<'---', # just read the first $VERSION line package Simple; $VERSION = '1.23'; # we should see this line $VERSION = eval $VERSION; # and ignore this one --- - <<'---', # just read the first $VERSION line in reopened package (1) + '1.23' => <<'---', # just read the first $VERSION line in reopened package (1) package Simple; $VERSION = '1.23'; package Error::Simple; $VERSION = '2.34'; package Simple; --- - <<'---', # just read the first $VERSION line in reopened package (2) + '1.23' => <<'---', # just read the first $VERSION line in reopened package (2) package Simple; package Error::Simple; $VERSION = '2.34'; package Simple; $VERSION = '1.23'; --- - <<'---', # mentions another module's $VERSION + '1.23' => <<'---', # mentions another module's $VERSION package Simple; $VERSION = '1.23'; if ( $Other::VERSION ) { # whatever } --- - <<'---', # mentions another module's $VERSION in a different package + '1.23' => <<'---', # mentions another module's $VERSION in a different package package Simple; $VERSION = '1.23'; package Simple2; @@ -104,21 +63,21 @@ if ( $Simple::VERSION ) { # whatever } --- - <<'---', # $VERSION checked only in assignments, not regexp ops + '1.23' => <<'---', # $VERSION checked only in assignments, not regexp ops package Simple; $VERSION = '1.23'; if ( $VERSION =~ /1\.23/ ) { # whatever } --- - <<'---', # $VERSION checked only in assignments, not relational ops + '1.23' => <<'---', # $VERSION checked only in assignments, not relational ops package Simple; $VERSION = '1.23'; if ( $VERSION == 3.45 ) { # whatever } --- - <<'---', # $VERSION checked only in assignments, not relational ops + '1.23' => <<'---', # $VERSION checked only in assignments, not relational ops package Simple; $VERSION = '1.23'; package Simple2; @@ -126,36 +85,36 @@ if ( $Simple::VERSION == 3.45 ) { # whatever } --- - <<'---', # Fully qualified $VERSION declared in package + '1.23' => <<'---', # Fully qualified $VERSION declared in package package Simple; $Simple::VERSION = 1.23; --- - <<'---', # Differentiate fully qualified $VERSION in a package + '1.23' => <<'---', # Differentiate fully qualified $VERSION in a package package Simple; $Simple2::VERSION = '999'; $Simple::VERSION = 1.23; --- - <<'---', # Differentiate fully qualified $VERSION and unqualified + '1.23' => <<'---', # Differentiate fully qualified $VERSION and unqualified package Simple; $Simple2::VERSION = '999'; $VERSION = 1.23; --- - <<'---', # $VERSION declared as package variable from within 'main' package + '1.23' => <<'---', # $VERSION declared as package variable from within 'main' package $Simple::VERSION = '1.23'; { package Simple; $x = $y, $cats = $dogs; } --- - <<'---', # $VERSION wrapped in parens - space inside + '1.23' => <<'---', # $VERSION wrapped in parens - space inside package Simple; ( $VERSION ) = '1.23'; --- - <<'---', # $VERSION wrapped in parens - no space inside + '1.23' => <<'---', # $VERSION wrapped in parens - no space inside package Simple; ($VERSION) = '1.23'; --- - <<'---', # $VERSION follows a spurious 'package' in a quoted construct + '1.23' => <<'---', # $VERSION follows a spurious 'package' in a quoted construct package Simple; __PACKAGE__->mk_accessors(qw( program socket proc @@ -163,25 +122,87 @@ __PACKAGE__->mk_accessors(qw( our $VERSION = "1.23"; --- - <<'---', # $VERSION using version.pm + '1.23' => <<'---', # $VERSION using version.pm package Simple; use version; our $VERSION = version->new('1.23'); --- - <<'---', # $VERSION using version.pm and qv() + '1.23' => <<'---', # $VERSION using version.pm and qv() package Simple; use version; our $VERSION = qv('1.230'); --- - <<'---', # Two version assignments, should ignore second one + '1.23' => <<'---', # Two version assignments, should ignore second one $Simple::VERSION = '1.230'; $Simple::VERSION = eval $Simple::VERSION; --- + '1.23' => <<'---', # declared & defined on same line with 'our' +package Simple; +our $VERSION = '1.23_00_00'; +--- + '1.23' => <<'---', # package NAME VERSION + package Simple 1.23; +--- + '1.23_01' => <<'---', # package NAME VERSION + package Simple 1.23_01; +--- + 'v1.2.3' => <<'---', # package NAME VERSION + package Simple v1.2.3; +--- + 'v1.2_3' => <<'---', # package NAME VERSION + package Simple v1.2_3; +--- ); +my %modules = reverse @modules; + +plan tests => 36 + 2 * keys( %modules ); -my( $i, $n ) = ( 1, scalar( @modules ) ); -foreach my $module ( @modules ) { +blib_load('Module::Build::ModuleInfo'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + +######################### + +# class method C<find_module_by_name> +my $module = Module::Build::ModuleInfo->find_module_by_name( + 'Module::Build::ModuleInfo' ); +ok( -e $module, 'find_module_by_name() succeeds' ); + + +# fail on invalid module name +my $pm_info = Module::Build::ModuleInfo->new_from_module( + 'Foo::Bar', inc => [] ); +ok( !defined( $pm_info ), 'fail if can\'t find module by module name' ); + + +# fail on invalid filename +my $file = File::Spec->catfile( 'Foo', 'Bar.pm' ); +$pm_info = Module::Build::ModuleInfo->new_from_file( $file, inc => [] ); +ok( !defined( $pm_info ), 'fail if can\'t find module by file name' ); + + +# construct from module filename +$file = File::Spec->catfile( 'lib', split( /::/, $dist->name ) ) . '.pm'; +$pm_info = Module::Build::ModuleInfo->new_from_file( $file ); +ok( defined( $pm_info ), 'new_from_file() succeeds' ); + +# construct from module name, using custom include path +$pm_info = Module::Build::ModuleInfo->new_from_module( + $dist->name, inc => [ 'lib', @INC ] ); +ok( defined( $pm_info ), 'new_from_module() succeeds' ); + + +foreach my $module ( sort keys %modules ) { + my $expected = $modules{$module}; SKIP: { skip( "No our() support until perl 5.6", 2 ) - if $] < 5.006 && $module =~ /\bour\b/; + if $] < 5.006 && $module =~ /\bour\b/; + skip( "No package NAME VERSION support until perl 5.11.1", 2 ) + if $] < 5.011001 && $module =~ /package\s+[\w\:\']+\s+v?[0-9._]+/; $dist->change_file( 'lib/Simple.pm', $module ); $dist->regen; @@ -191,19 +212,17 @@ foreach my $module ( @modules ) { my $pm_info = Module::Build::ModuleInfo->new_from_file( $file ); # Test::Builder will prematurely numify objects, so use this form - ok( $pm_info->version eq '1.23', - "correct module version ($i of $n)" ); - is( $warnings, '', 'no warnings from parsing' ); - $i++; + my $errs; + ok( $pm_info->version eq $expected, + "correct module version (expected '$expected')" ) + or $errs++; + is( $warnings, '', 'no warnings from parsing' ) or $errs++; + diag "Got: '@{[$pm_info->version]}'\nModule contents:\n$module" if $errs; } } # revert to pristine state -$dist->remove; -$dist = DistGen->new( dir => $tmp ); -$dist->regen; -$dist->chdir_in; - +$dist->regen( clean => 1 ); # Find each package only once $dist->change_file( 'lib/Simple.pm', <<'---' ); @@ -249,19 +268,15 @@ $pm_info = Module::Build::ModuleInfo->new_from_file( $file ); is( $pm_info->version, '1.23_01', 'alpha version reported'); # NOTE the following test has be done this way because Test::Builder is -# too smart for our own good and tries to see if the version object is a +# too smart for our own good and tries to see if the version object is a # dual-var, which breaks with alpha versions: # Argument "1.23_0100" isn't numeric in addition (+) at -# /usr/lib/perl5/5.8.7/Test/Builder.pm line 505. +# /usr/lib/perl5/5.8.7/Test/Builder.pm line 505. ok( $pm_info->version > 1.23, 'alpha version greater than non'); # revert to pristine state -$dist->remove; -$dist = DistGen->new( dir => $tmp ); -$dist->regen; -$dist->chdir_in; - +$dist->regen( clean => 1 ); # parse $VERSION lines scripts for package main my @scripts = ( @@ -313,7 +328,7 @@ $::VERSION = 0.01; --- ); -( $i, $n ) = ( 1, scalar( @scripts ) ); +my ( $i, $n ) = ( 1, scalar( @scripts ) ); foreach my $script ( @scripts ) { $dist->change_file( 'bin/simple.plx', $script ); $dist->regen; @@ -402,7 +417,7 @@ __DATA__ is( $pm_info->name, 'Simple', 'found default package' ); is( $pm_info->version, '0.01', 'version for default package' ); my @packages = $pm_info->packages_inside; - is_deeply(\@packages, ['Simple']); + is_deeply(\@packages, ['Simple'], 'packages inside'); } { @@ -419,10 +434,7 @@ $VERSION = version->new('0.61.' . (qw$Revision: 129 $)[1]); is( $pm_info->name, 'Simple', 'found default package' ); is( $pm_info->version, '0.60.128', 'version for default package' ); my @packages = $pm_info->packages_inside; - is_deeply([sort @packages], ['Simple', 'Simple::Simon']); + is_deeply([sort @packages], ['Simple', 'Simple::Simon'], 'packages inside'); is( $pm_info->version('Simple::Simon'), '0.61.129', 'version for embedded package' ); } - -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/mymeta.t b/cpan/Module-Build/t/mymeta.t new file mode 100644 index 0000000000..c60a5b2420 --- /dev/null +++ b/cpan/Module-Build/t/mymeta.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest tests => 3; + +blib_load('Module::Build'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; +$dist->chdir_in; + +######################### + +# Test MYMETA generation +{ + ok( ! -e "MYMETA.yml", "MYMETA.yml doesn't exist before Build.PL runs" ); + my $output; + $output = stdout_of sub { $dist->run_build_pl }; + like($output, qr/Creating new 'MYMETA.yml' with configuration results/, + "Saw MYMETA.yml creation message" + ); + ok( -e "MYMETA.yml", "MYMETA.yml exists" ); +} + +######################### + diff --git a/cpan/Module-Build/t/new_from_context.t b/cpan/Module-Build/t/new_from_context.t index ee34f07367..f45a1760eb 100644 --- a/cpan/Module-Build/t/new_from_context.t +++ b/cpan/Module-Build/t/new_from_context.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 4; +use MBTest tests => 2; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); use IO::File; my $tmp = MBTest->tmpdir; @@ -25,7 +24,4 @@ my $mb = eval { Module::Build->new_from_context}; ok(! $@, 'dodged the bullet') or die; ok($mb); -# cleanup -$dist->remove; - # vim:ts=2:sw=2:et:sta diff --git a/cpan/Module-Build/t/notes.t b/cpan/Module-Build/t/notes.t index 29f1fc38b1..4568e7c36a 100644 --- a/cpan/Module-Build/t/notes.t +++ b/cpan/Module-Build/t/notes.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 13; +use MBTest tests => 11; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; @@ -65,6 +64,3 @@ $mb = Module::Build->resume; ok $mb; is $mb->notes('foo'), 'bar'; - -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/parents.t b/cpan/Module-Build/t/parents.t index 666fb05601..825f79a787 100644 --- a/cpan/Module-Build/t/parents.t +++ b/cpan/Module-Build/t/parents.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 28; +use MBTest tests => 26; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); ######################### diff --git a/cpan/Module-Build/t/perl_mb_opt.t b/cpan/Module-Build/t/perl_mb_opt.t new file mode 100644 index 0000000000..70089ee6be --- /dev/null +++ b/cpan/Module-Build/t/perl_mb_opt.t @@ -0,0 +1,62 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 8; # or 'no_plan' + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in->regen; + +$dist->add_file('t/subtest/foo.t', <<'END_T'); +use strict; +use Test::More tests => 1; +ok(1, "this is a recursive test"); +END_T + +$dist->regen; + +# get a Module::Build object and test with it +my $mb = $dist->new_from_context(); # quiet by default +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); +ok( ! $mb->recursive_test_files, "set for no recursive testing" ); + +# set for recursive testing using PERL_MB_OPT +{ + local $ENV{PERL_MB_OPT} = "--verbose --recursive_test_files 1"; + + my $out = stdout_stderr_of( sub { + $dist->run_build('test'); + }); + like( $out, qr/this is a recursive test/, + "recursive tests run via PERL_MB_OPT" + ); +} + +# set Build.PL opts using PERL_MB_OPT +{ + local $ENV{PERL_MB_OPT} = "--verbose --recursive_test_files 1"; + my $mb = $dist->new_from_context(); # quiet by default + ok( $mb->recursive_test_files, "PERL_MB_OPT set recusive tests in Build.PL" ); + ok( $mb->verbose, "PERL_MB_OPT set verbose in Build.PL" ); +} + +# verify settings preserved during 'Build test' +{ + ok( !$ENV{PERL_MB_OPT}, "PERL_MB_OPT cleared" ); + my $out = stdout_stderr_of( sub { + $dist->run_build('test'); + }); + like( $out, qr/this is a recursive test/, + "recursive tests run via Build object" + ); +} + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/cpan/Module-Build/t/pod_parser.t b/cpan/Module-Build/t/pod_parser.t index 42a78209e2..64d4c75348 100644 --- a/cpan/Module-Build/t/pod_parser.t +++ b/cpan/Module-Build/t/pod_parser.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 8; +use MBTest tests => 9; -use_ok 'Module::Build::PodParser'; -ensure_blib('Module::Build::PodParser'); +blib_load('Module::Build::PodParser'); ######################### @@ -66,3 +65,26 @@ EOF } +{ + # Try again with mixed-case =head1s. + untie *FH; + tie *FH, 'IO::StringBased', <<'EOF'; +=head1 Name + +Foo::Bar - Perl extension for blah blah blah + +=head1 Author + +C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004. + +Home page: http://example.com/~eh/ + +=cut +EOF + + my $pp = Module::Build::PodParser->new(fh => \*FH); + ok $pp, 'object created'; + + is $pp->get_author->[0], 'C<Foo::Bar> was written by Engelbert Humperdinck I<E<lt>eh@example.comE<gt>> in 2004.', 'author'; + is $pp->get_abstract, 'Perl extension for blah blah blah', 'abstract'; +} diff --git a/cpan/Module-Build/t/ppm.t b/cpan/Module-Build/t/ppm.t index 7fb6450648..acbd56d1f5 100644 --- a/cpan/Module-Build/t/ppm.t +++ b/cpan/Module-Build/t/ppm.t @@ -3,20 +3,19 @@ use strict; use lib 't/lib'; use MBTest; - -use Module::Build; -use Module::Build::ConfigData; use Config; +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); my $manpage_support = Module::Build::ConfigData->feature('manpage_support'); my $HTML_support = Module::Build::ConfigData->feature('HTML_support'); +my $tmp; + { - my ($have_c_compiler, $C_support_feature) = check_compiler(); - if (! $C_support_feature) { - plan skip_all => 'C_support not enabled'; - } elsif ( ! $have_c_compiler ) { - plan skip_all => 'C_support enabled, but no compiler found'; + my ($have_c_compiler, $tmp_exec) = check_compiler(); + if ( ! $have_c_compiler ) { + plan skip_all => 'No compiler found'; } elsif ( !$Config{usedl} ) { plan skip_all => 'Perl not compiled for dynamic loading' } elsif ( ! eval {require Archive::Tar} ) { @@ -26,13 +25,11 @@ my $HTML_support = Module::Build::ConfigData->feature('HTML_support'); } elsif ( $^O eq 'VMS' ) { plan skip_all => "Needs porting work on VMS"; } else { - plan tests => 13; + plan tests => 12; } + require Cwd; + $tmp = MBTest->tmpdir( $tmp_exec ? () : (DIR => Cwd::cwd) ); } -ensure_blib('Module::Build'); - - -my $tmp = MBTest->tmpdir; use DistGen; @@ -66,7 +63,6 @@ $dist->chdir_in; use File::Spec::Functions qw(catdir); -use Module::Build; my @installstyle = qw(lib perl5); my $mb = Module::Build->new_from_context( verbose => 0, @@ -98,13 +94,10 @@ my $varchname = Module::Build::PPMMaker->_varchname($mb->config); # do a strict string comparison, but absent an XML parser it's the # best we can do. is $ppd, <<"---"; -<SOFTPKG NAME="$dist_filename" VERSION="0,01,0,0"> - <TITLE>@{[$dist->name]}</TITLE> +<SOFTPKG NAME="$dist_filename" VERSION="0.01"> <ABSTRACT>Perl extension for blah blah blah</ABSTRACT> <AUTHOR>A. U. Thor, a.u.thor\@a.galaxy.far.far.away</AUTHOR> <IMPLEMENTATION> - <PERLCORE VERSION="$perl_version" /> - <OS NAME="$^O" /> <ARCHITECTURE NAME="$varchname" /> <CODEBASE HREF="/path/to/codebase-xs" /> </IMPLEMENTATION> @@ -185,9 +178,6 @@ SKIP: { } -$dist->remove; - - ######################################## sub exists_ok { diff --git a/cpan/Module-Build/t/properties/module_name.t b/cpan/Module-Build/t/properties/module_name.t new file mode 100644 index 0000000000..c266b41ba2 --- /dev/null +++ b/cpan/Module-Build/t/properties/module_name.t @@ -0,0 +1,53 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 4; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# enter the directory and generate the skeleton files +my $dist = DistGen->new( name => "Not::So::Simple" )->chdir_in; + +#--------------------------------------------------------------------------# +# try getting module_name from dist directory name +#--------------------------------------------------------------------------# + +$dist->change_build_pl( + dist_name => 'Random-Name', + dist_version => 1, +)->regen; + +my $mb = $dist->new_from_context(); +isa_ok( $mb, "Module::Build" ); +is( $mb->module_name, "Not::So::Simple", + "module_name guessed from directory name" +); + +#--------------------------------------------------------------------------# +# Try getting module_name from dist_version_from +#--------------------------------------------------------------------------# + +$dist->add_file( 'lib/Simple/Name.pm', << 'END_PACKAGE' ); +package Simple::Name; +our $VERSION = 1.23; +1; +END_PACKAGE + +$dist->change_build_pl( + dist_name => 'Random-Name', + dist_version_from => 'lib/Simple/Name.pm', + dist_abstract => "Don't complain about missing abstract", +)->regen( clean => 1 ); + +$mb = $dist->new_from_context(); +isa_ok( $mb, "Module::Build" ); +is( $mb->module_name, "Simple::Name", + "module_name guessed from dist_version_from" +); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/cpan/Module-Build/t/properties/needs_compiler.t b/cpan/Module-Build/t/properties/needs_compiler.t new file mode 100644 index 0000000000..f298e82739 --- /dev/null +++ b/cpan/Module-Build/t/properties/needs_compiler.t @@ -0,0 +1,122 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest; +use DistGen; + +plan tests => 19; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +my $dist = DistGen->new->regen->chdir_in; + +# get a Module::Build object and test with it +my $mb; +stderr_of(sub { + ok( $mb = $dist->new_from_context, "Default Build.PL" ); +}); + +ok( ! $mb->needs_compiler, "needs_compiler is false" ); +ok( ! exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'}, + "ExtUtils::CBuilder is not in build_requires" +); + +#--------------------------------------------------------------------------# +# try with c_source +#--------------------------------------------------------------------------# +$dist->change_build_pl({ + module_name => $dist->name, + license => 'perl', + c_source => 'src', +}); +$dist->regen; +stderr_of(sub { + ok( $mb = $dist->new_from_context, + "Build.PL with c_source" + ); +}); +is( $mb->c_source, 'src', "c_source is set" ); +ok( $mb->needs_compiler, "needs_compiler is true" ); +ok( exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'}, + "ExtUtils::CBuilder was added to build_requires" +); + +#--------------------------------------------------------------------------# +# try with xs files +#--------------------------------------------------------------------------# +$dist = DistGen->new(dir => 'MBTest', xs => 1); +$dist->regen; +$dist->chdir_in; + +stderr_of(sub { + ok( $mb = $dist->new_from_context, + "Build.PL with xs files" + ); +}); +ok( $mb->needs_compiler, "needs_compiler is true" ); +ok( exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'}, + "ExtUtils::CBuilder was added to build_requires" +); + +#--------------------------------------------------------------------------# +# force needs_compiler off, despite xs modules +#--------------------------------------------------------------------------# + +$dist->change_build_pl({ + module_name => $dist->name, + license => 'perl', + needs_compiler => 0, +}); +$dist->regen; + +stderr_of(sub { + ok( $mb = $dist->new_from_context , + "Build.PL with xs files, but needs_compiler => 0" + ); +}); +is( $mb->needs_compiler, 0, "needs_compiler is false" ); +ok( ! exists $mb->{properties}{build_requires}{'ExtUtils::CBuilder'}, + "ExtUtils::CBuilder is not in build_requires" +); + +#--------------------------------------------------------------------------# +# don't override specific EU::CBuilder build_requires +#--------------------------------------------------------------------------# + +$dist->change_build_pl({ + module_name => $dist->name, + license => 'perl', + build_requires => { 'ExtUtils::CBuilder' => 0.2 }, +}); +$dist->regen; + +stderr_of(sub { + ok( $mb = $dist->new_from_context , + "Build.PL with xs files, build_requires EU::CB 0.2" + ); +}); +ok( $mb->needs_compiler, "needs_compiler is true" ); +is( $mb->build_requires->{'ExtUtils::CBuilder'}, 0.2, + "build_requires for ExtUtils::CBuilder is correct version" +); + +#--------------------------------------------------------------------------# +# falsify compiler and test error handling +#--------------------------------------------------------------------------# + +my $err = stderr_of( sub { + $mb = $dist->new_from_context( config => { cc => "adfasdfadjdjk" } ) +}); +ok( $mb, "Build.PL while hiding compiler" ); +like( $err, qr/no compiler detected/, + "hidden compiler resulted in warning message during Build.PL" +); +eval { $mb->dispatch('build') }; +like( $@, qr/no compiler detected/, + "hidden compiler resulted in fatal message during Build" +); + + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/cpan/Module-Build/t/properties/share_dir.t b/cpan/Module-Build/t/properties/share_dir.t new file mode 100644 index 0000000000..f781a8a7ce --- /dev/null +++ b/cpan/Module-Build/t/properties/share_dir.t @@ -0,0 +1,228 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use MBTest; +use File::Spec::Functions qw/catdir catfile/; + +#--------------------------------------------------------------------------# +# Begin testing +#--------------------------------------------------------------------------# + +plan tests => 21; + +blib_load('Module::Build'); + +#--------------------------------------------------------------------------# +# Create test distribution +#--------------------------------------------------------------------------# + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp, name => 'Simple::Share' ); +$dist->regen; +$dist->chdir_in; + +#--------------------------------------------------------------------------# +# Test setting 'share_dir' +#--------------------------------------------------------------------------# + +my $mb = $dist->new_from_context; + +# Test without a 'share' dir +ok( $mb, "Created Module::Build object" ); +is( $mb->share_dir, undef, + "default share undef if no 'share' dir exists" +); +ok( ! exists $mb->{properties}{requires}{'File::ShareDir'}, + "File::ShareDir not added to 'requires'" +); + +# Add 'share' dir and an 'other' dir and content +$dist->add_file('share/foo.txt',<< '---'); +This is foo.txt +--- +$dist->add_file('other/share/bar.txt',<< '---'); +This is bar.txt +--- +$dist->regen; +ok( -e catfile(qw/share foo.txt/), "Created 'share' directory" ); +ok( -e catfile(qw/other share bar.txt/), "Created 'other/share' directory" ); + +# Check default when share_dir is not given +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Default share_dir set as dist-type share" +); +is( $mb->{properties}{requires}{'File::ShareDir'}, '1.00', + "File::ShareDir 1.00 added to 'requires'" +); + +# share_dir set to scalar +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => 'share', + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Scalar share_dir set as dist-type share" +); + +# share_dir set to arrayref +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => [ 'share' ], + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Arrayref share_dir set as dist-type share" +); + +# share_dir set to hashref w scalar +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => { dist => 'share' }, + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Hashref share_dir w/ scalar dist set as dist-type share" +); + +# share_dir set to hashref w array +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => { dist => [ 'share' ] }, + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, { dist => [ 'share' ] }, + "Hashref share_dir w/ arrayref dist set as dist-type share" +); + +# Generate a module sharedir (scalar) +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => { + dist => 'share', + module => { $dist->name => 'other/share' }, + }, + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, + { dist => [ 'share' ], + module => { $dist->name => ['other/share'] }, + }, + "Hashref share_dir w/ both dist and module shares (scalar-form)" +); + +# Generate a module sharedir (array) +$dist->change_build_pl( + { + module_name => $dist->name, + license => 'perl', + share_dir => { + dist => [ 'share' ], + module => { $dist->name => ['other/share'] }, + }, + } +); +$dist->regen; +stdout_stderr_of( sub { $mb = $dist->new_from_context }); +is_deeply( $mb->share_dir, + { dist => [ 'share' ], + module => { $dist->name => ['other/share'] }, + }, + "Hashref share_dir w/ both dist and module shares (array-form)" +); + +#--------------------------------------------------------------------------# +# test constructing to/from mapping +#--------------------------------------------------------------------------# + +is_deeply( $mb->_find_share_dir_files, + { + catfile(qw/share foo.txt/) => catfile(qw/dist Simple-Share foo.txt/), + catfile(qw/other share bar.txt/) => catfile(qw/module Simple-Share bar.txt/), + }, + "share_dir filemap for copying to lib complete" +); + +#--------------------------------------------------------------------------# +# test moving files to blib +#--------------------------------------------------------------------------# + +$mb->dispatch('build'); + +ok( -d 'blib', "Build ran and blib exists" ); +ok( -d 'blib/lib/auto/share', "blib/lib/auto/share exists" ); + +my $share_list = Module::Build->rscan_dir('blib/lib/auto/share', sub {-f}); + +is_deeply( + [ sort @$share_list ], [ + 'blib/lib/auto/share/dist/Simple-Share/foo.txt', + 'blib/lib/auto/share/module/Simple-Share/bar.txt', + ], + "share_dir files copied to blib" +); + +#--------------------------------------------------------------------------# +# test installing +#--------------------------------------------------------------------------# + +my $temp_install = 'temp_install'; +mkdir $temp_install; +ok( -d $temp_install, "temp install dir created" ); + +$mb->install_base($temp_install); +stdout_of( sub { $mb->dispatch('install') } ); + +$share_list = Module::Build->rscan_dir( + "$temp_install/lib/perl5/auto/share", sub {-f} +); + +is_deeply( + [ sort @$share_list ], [ + "$temp_install/lib/perl5/auto/share/dist/Simple-Share/foo.txt", + "$temp_install/lib/perl5/auto/share/module/Simple-Share/bar.txt", + ], + "share_dir files correctly installed" +); + +#--------------------------------------------------------------------------# +# test with File::ShareDir +#--------------------------------------------------------------------------# + +SKIP: { + eval { require File::ShareDir; File::ShareDir->VERSION(1.00) }; + skip "needs File::ShareDir 1.00", 2 if $@; + + unshift @INC, File::Spec->catdir($temp_install, qw/lib perl5/); + require Simple::Share; + + eval {File::ShareDir::dist_file('Simple-Share','foo.txt') }; + is( $@, q{}, "Found shared dist file" ); + + eval {File::ShareDir::module_file('Simple::Share','bar.txt') }; + is( $@, q{}, "Found shared module file" ); +} diff --git a/cpan/Module-Build/t/resume.t b/cpan/Module-Build/t/resume.t new file mode 100644 index 0000000000..add123d3d4 --- /dev/null +++ b/cpan/Module-Build/t/resume.t @@ -0,0 +1,43 @@ +use strict; +use lib 't/lib'; +use MBTest; +plan tests => 3; # or 'no_plan' +use DistGen; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in; +$dist->add_file('mylib/MBUtil.pm', << "---"); +package MBUtil; +sub foo { 42 } +1; +--- + +$dist->add_file('Build.PL', << "---"); +use strict; +use lib 'mylib'; +use MBUtil; +use Module::Build; + +die unless MBUtil::foo() == 42; + +my \$builder = Module::Build->new( +module_name => '$dist->{name}', +license => 'perl', +); + +\$builder->create_build_script(); +--- + +$dist->regen; + +# get a Module::Build object and test with it +my $mb = $dist->new_from_context(); # quiet by default +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); +ok( ( grep { /mylib/ } @INC ), "resume added \@INC addition to \@INC"); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/cpan/Module-Build/t/runthrough.t b/cpan/Module-Build/t/runthrough.t index 21d3d1c113..741755c12c 100644 --- a/cpan/Module-Build/t/runthrough.t +++ b/cpan/Module-Build/t/runthrough.t @@ -2,12 +2,10 @@ use strict; use lib 't/lib'; -use MBTest tests => 32; +use MBTest tests => 30; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); - -use Module::Build::ConfigData; +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); my $have_yaml = Module::Build::ConfigData->feature('YAML_support'); ######################### @@ -24,6 +22,9 @@ $dist->change_build_pl requires => { 'File::Spec' => 0 }, }); +$dist->add_file( 'MANIFEST.SKIP', <<'---' ); +^MYMETA.yml$ +--- $dist->add_file( 'script', <<'---' ); #!perl -w print "Hello, World!\n"; @@ -169,12 +170,11 @@ SKIP: { # do a strict string comparison, but absent an XML parser it's the # best we can do. is $ppd, <<'EOF'; -<SOFTPKG NAME="Simple" VERSION="0,01,0,0"> - <TITLE>Simple</TITLE> +<SOFTPKG NAME="Simple" VERSION="0.01"> <ABSTRACT>Perl extension for blah blah blah</ABSTRACT> <AUTHOR>A. U. Thor, a.u.thor@a.galaxy.far.far.away</AUTHOR> <IMPLEMENTATION> - <DEPENDENCY NAME="File-Spec" VERSION="0,0,0,0" /> + <REQUIRE NAME="File::Spec" VERSION="0" /> <CODEBASE HREF="/path/to/codebase" /> </IMPLEMENTATION> </SOFTPKG> @@ -189,8 +189,6 @@ ok ! -e $mb->build_script; ok ! -e $mb->config_dir; ok ! -e $mb->dist_dir; -$dist->remove; - SKIP: { skip( 'Windows-only test', 4 ) unless $^O =~ /^MSWin/; @@ -223,8 +221,5 @@ echo Hello, World! my $out = slurp( $script_file ); is $out, $script_data, ' unmodified by pl2bat'; - $dist->remove; } -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/sample.t b/cpan/Module-Build/t/sample.t new file mode 100644 index 0000000000..d83bc56ecc --- /dev/null +++ b/cpan/Module-Build/t/sample.t @@ -0,0 +1,20 @@ +# sample.t -- a sample test file for Module::Build + +use strict; +use lib 't/lib'; +use MBTest tests => 2; # or 'no_plan' +use DistGen; + +# Ensure any Module::Build modules are loaded from correct directory +blib_load('Module::Build'); + +# create dist object in a temp directory +# enter the directory and generate the skeleton files +my $dist = DistGen->new->chdir_in->regen; + +# get a Module::Build object and test with it +my $mb = $dist->new_from_context(); # quiet by default +isa_ok( $mb, "Module::Build" ); +is( $mb->dist_name, "Simple", "dist_name is 'Simple'" ); + +# vim:ts=2:sw=2:et:sta:sts=2 diff --git a/cpan/Module-Build/t/script_dist.t b/cpan/Module-Build/t/script_dist.t index e6b7fd8832..02faca0132 100644 --- a/cpan/Module-Build/t/script_dist.t +++ b/cpan/Module-Build/t/script_dist.t @@ -8,7 +8,8 @@ use MBTest 'no_plan'; use DistGen qw(undent); -use Module::Build; +blib_load('Module::Build'); +blib_load('Module::Build::ConfigData'); # XXX DistGen shouldn't be assuming module-ness? my $dist = DistGen->new(dir => MBTest->tmpdir); @@ -69,12 +70,11 @@ is_deeply($mb->dist_author, ['A. U. Thor, a.u.thor@a.galaxy.far.far.away']); ok $mb->dispatch('distmeta'); -use Module::Build::ConfigData; SKIP: { skip( 'YAML_support feature is not enabled', 1 ) unless Module::Build::ConfigData->feature('YAML_support'); - require YAML; - my $yml = YAML::LoadFile('META.yml'); + require YAML::Tiny; + my $yml = YAML::Tiny::LoadFile('META.yml'); is_deeply($yml->{provides}, \%meta_provides); } $dist->chdir_original if $dist->did_chdir; diff --git a/cpan/Module-Build/t/test_file_exts.t b/cpan/Module-Build/t/test_file_exts.t index 9dbf73e290..5bb803c7aa 100644 --- a/cpan/Module-Build/t/test_file_exts.t +++ b/cpan/Module-Build/t/test_file_exts.t @@ -2,11 +2,10 @@ use strict; use lib 't/lib'; -use MBTest tests => 5; +use MBTest tests => 3; use DistGen; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; my $dist = DistGen->new( dir => $tmp ); @@ -39,7 +38,4 @@ my $out = uc(stdout_of( like $out, qr/^OK 1 - FIRST MYTEST[.]S/m, 'Should see first test output'; like $out, qr/^OK 2 - SECOND MYTEST[.]S/m, 'Should see second test output'; -# Cleanup. -$dist->remove; - # vim:ts=4:sw=4:et:sta diff --git a/cpan/Module-Build/t/test_type.t b/cpan/Module-Build/t/test_type.t index 3c6cfb61e4..fe4d599d72 100644 --- a/cpan/Module-Build/t/test_type.t +++ b/cpan/Module-Build/t/test_type.t @@ -9,10 +9,9 @@ BEGIN { use strict; use lib 't/lib'; -use MBTest tests => 9; +use MBTest tests => 7; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; @@ -72,6 +71,4 @@ like($output, qr/\.\. ?OK/); is($::x, 3, "called a third time"); -$dist->remove; - # vim:ts=4:sw=4:et:sta diff --git a/cpan/Module-Build/t/test_types.t b/cpan/Module-Build/t/test_types.t index 5f3f5cff8d..d88e215aa3 100644 --- a/cpan/Module-Build/t/test_types.t +++ b/cpan/Module-Build/t/test_types.t @@ -2,16 +2,13 @@ use strict; use lib 't/lib'; -use MBTest tests => 15 + 12; +use MBTest tests => 25; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); - -my $tmp = MBTest->tmpdir; +blib_load('Module::Build'); use DistGen; -my $dist = DistGen->new(dir => $tmp); +my $dist = DistGen->new()->chdir_in; $dist->add_file('t/special_ext.st', <<'---'); #!perl @@ -34,7 +31,6 @@ die "don't run this non-test file"; --- $dist->regen; -$dist->chdir_in; ######################### my $mb = Module::Build->subclass( @@ -98,10 +94,10 @@ is(scalar(@{[$all_output =~ m/OK 1/mg]}), 3 ); is(scalar(@{[$all_output =~ m/OK/mg]}), 8 ); is(scalar(@{[$all_output =~ m/ALL TESTS SUCCESSFUL\./mg]}), 1); -$dist->remove; - { # once-again +$dist->revert; + $dist->add_file('t/foo/special.st', <<'---'); #!perl use Test::More tests => 2; @@ -114,7 +110,6 @@ use strict; use Simple; ok 1; --- $dist->regen; -$dist->chdir_in; my $mb = Module::Build->subclass( code => q# @@ -174,7 +169,6 @@ like($all_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m); is(scalar(@{[$all_output =~ m/(OK 1)/mg]}), 5 ); is(scalar(@{[$all_output =~ m/(OK)/mg]}), 13 ); -$dist->remove; } # end once-again # vim:ts=4:sw=4:et:sta diff --git a/cpan/Module-Build/t/tilde.t b/cpan/Module-Build/t/tilde.t index 5b39204171..692ade0c8a 100644 --- a/cpan/Module-Build/t/tilde.t +++ b/cpan/Module-Build/t/tilde.t @@ -4,10 +4,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 18; +use MBTest tests => 16; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; @@ -111,6 +110,3 @@ SKIP: { like( run_sample( $p => "~$me/foo")->$p(), qr($expected)i ); } - -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/use_tap_harness.t b/cpan/Module-Build/t/use_tap_harness.t index d14cb052ba..f6e7e5073a 100644 --- a/cpan/Module-Build/t/use_tap_harness.t +++ b/cpan/Module-Build/t/use_tap_harness.t @@ -4,7 +4,7 @@ use strict; use Test::More; use lib 't/lib'; if (eval { require TAP::Harness } && TAP::Harness->VERSION >= 3) { - plan tests => 8; + plan tests => 9; } else { plan skip_all => 'TAP::Harness 3+ not installed' } @@ -12,21 +12,24 @@ if (eval { require TAP::Harness } && TAP::Harness->VERSION >= 3) { use MBTest; use DistGen; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; my $dist = DistGen->new( dir => $tmp ); $dist->regen; - $dist->chdir_in; + ######################### # Make sure that TAP::Harness properly does its thing. -ok my $mb = Module::Build->new( +$dist->change_build_pl( module_name => $dist->name, use_tap_harness => 1, quiet => 1, -), 'Construct build object with test_file_exts parameter'; +); +$dist->regen; + +ok my $mb = $dist->new_from_context, + 'Construct build object with test_file_exts parameter'; $mb->add_to_cleanup('save_out'); # Use uc() so we don't confuse the current test output @@ -40,12 +43,16 @@ like $out, qr/^ALL TESTS SUCCESSFUL/m, 'Should see test success message'; ######################### # Make sure that arguments are passed through to TAP::Harness. -ok $mb = Module::Build->new( +$dist->change_build_pl( module_name => $dist->name, use_tap_harness => 1, tap_harness_args => { verbosity => 0 }, quiet => 1, -), 'Construct build object with test_file_exts parameter'; +); +$dist->regen; + +ok $mb = $dist->new_from_context, + 'Construct build object with test_file_exts parameter'; $mb->add_to_cleanup('save_out'); # Use uc() so we don't confuse the current test output @@ -56,6 +63,32 @@ $out = uc(stdout_of( unlike $out, qr/^OK 1/m, 'Should not see first test output'; like $out, qr/^ALL TESTS SUCCESSFUL/m, 'Should see test success message'; -$dist->remove; +#--------------------------------------------------------------------------# +# test that a failing test dies +#--------------------------------------------------------------------------# + +$dist->change_build_pl( + module_name => $dist->name, + use_tap_harness => 1, + tap_harness_args => { verbosity => 1 }, + quiet => 1, +); +$dist->change_file('t/basic.t',<<"---"); +use Test::More tests => 1; +use strict; + +use $dist->{name}; +ok 0; +--- +$dist->regen; + +ok $mb = $dist->new_from_context, + 'Construct build object after setting tests to fail'; +# Use uc() so we don't confuse the current test output +$out = stdout_stderr_of( sub { $dist->run_build('test')} ); +ok( $?, "'Build test' had non-zero exit code" ); +like( $out, qr{Errors in testing\. Cannot continue\.}, + "Saw emulated Test::Harness die() message" +); # vim:ts=4:sw=4:et:sta diff --git a/cpan/Module-Build/t/versions.t b/cpan/Module-Build/t/versions.t index 7f511e58f6..5eafbac297 100644 --- a/cpan/Module-Build/t/versions.t +++ b/cpan/Module-Build/t/versions.t @@ -2,10 +2,9 @@ use strict; use lib 't/lib'; -use MBTest tests => 4; +use MBTest tests => 2; -use_ok 'Module::Build'; -ensure_blib('Module::Build'); +blib_load('Module::Build'); my $tmp = MBTest->tmpdir; @@ -20,7 +19,3 @@ my $file = File::Spec->catfile( $dist->dirname, 'lib', @mod ) . '.pm'; is( Module::Build->version_from_file( $file ), '0.01', 'version_from_file' ); ok( Module::Build->compare_versions( '1.01_01', '>', '1.01' ), 'compare: 1.0_01 > 1.0' ); - - -# cleanup -$dist->remove; diff --git a/cpan/Module-Build/t/write_default_maniskip.t b/cpan/Module-Build/t/write_default_maniskip.t index 084d81ed3e..40389f20dc 100644 --- a/cpan/Module-Build/t/write_default_maniskip.t +++ b/cpan/Module-Build/t/write_default_maniskip.t @@ -8,14 +8,14 @@ use MBTest 'no_plan'; use DistGen; use Cwd; -use_ok 'Module::Build'; -ensure_blib 'Module::Build'; +blib_load('Module::Build'); { my $cwd = Cwd::cwd; chdir MBTest->tmpdir(); my $build = Module::Build->new( + module_name => "Foo::Bar", dist_name => "Foo-Bar", dist_version => '1.23', ); diff --git a/cpan/Module-Build/t/xs.t b/cpan/Module-Build/t/xs.t index e3f1ed7dd1..84f82d9a60 100644 --- a/cpan/Module-Build/t/xs.t +++ b/cpan/Module-Build/t/xs.t @@ -3,41 +3,36 @@ use strict; use lib 't/lib'; use MBTest; -use Module::Build; use Config; my $tmp; +blib_load('Module::Build'); + { - my ($have_c_compiler, $C_support_feature, $tmp_exec) = check_compiler(); + my ($have_c_compiler, $tmp_exec) = check_compiler(); - if (! $C_support_feature) { - plan skip_all => 'C_support not enabled'; - } elsif ( !$have_c_compiler ) { - plan skip_all => 'C_support enabled, but no compiler found'; + if ( !$have_c_compiler ) { + plan skip_all => 'No compiler found'; } elsif ( $^O eq 'VMS' ) { plan skip_all => 'Child test output confuses harness'; } elsif ( !$Config{usedl} ) { plan skip_all => 'Perl not compiled for dynamic loading' } else { - plan tests => 23; + plan tests => 20; } require Cwd; - $tmp = MBTest->tmpdir( $tmp_exec ? undef : Cwd::cwd ); + $tmp = MBTest->tmpdir( $tmp_exec ? () : (DIR => Cwd::cwd) ); } -ensure_blib('Module::Build'); ######################### use DistGen; -my $dist = DistGen->new( dir => $tmp, xs => 1 ); -$dist->regen; - -$dist->chdir_in; -my $mb = Module::Build->new_from_context; +my $dist = DistGen->new( dir => $tmp, xs => 1 )->chdir_in->regen; +my $mb = $dist->new_from_context; eval {$mb->dispatch('clean')}; is $@, ''; @@ -68,7 +63,7 @@ is $@, ''; } { - # Try again in a subprocess + # Try again in a subprocess eval {$mb->dispatch('clean')}; is $@, ''; @@ -83,7 +78,7 @@ is $@, ''; # We can't be verbose in the sub-test, because Test::Harness will # think that the output is for the top-level test. -eval {$mb->dispatch('test')}; +stdout_stderr_of( sub { eval {$mb->dispatch('test')} }); is $@, ''; eval {$mb->dispatch('clean')}; @@ -106,42 +101,31 @@ is $@, ''; # Make sure blib/ is gone after 'realclean' ok ! -e 'blib'; - -# cleanup -$dist->remove; - - ######################################## # Try a XS distro with a deep namespace -$dist = DistGen->new( name => 'Simple::With::Deep::Name', - dir => $tmp, xs => 1 ); -$dist->regen; -$dist->chdir_in; -$mb = Module::Build->new_from_context; -is $@, ''; +$dist->reset( name => 'Simple::With::Deep::Name', dir => $tmp, xs => 1 ); +$dist->chdir_in->regen; -$mb->dispatch('build'); -is $@, ''; +$mb = $dist->new_from_context; -$mb->dispatch('test'); +eval { $mb->dispatch('build') }; is $@, ''; -$mb->dispatch('realclean'); +stdout_stderr_of( sub { eval { $mb->dispatch('test') } } ); is $@, ''; -# cleanup -$dist->remove; - +eval { $mb->dispatch('realclean') }; +is $@, ''; ######################################## # Try a XS distro using a flat directory structure # and a 'dist_name' instead of a 'module_name' -$dist = DistGen->new( name => 'Dist-Name', dir => $tmp, xs => 1 ); +$dist->reset( name => 'Dist-Name', dir => $tmp, xs => 1 )->chdir_in; $dist->remove_file('lib/Dist-Name.pm'); $dist->remove_file('lib/Dist-Name.xs'); @@ -211,20 +195,15 @@ ok( Simple::okay() eq 'ok' ); --- $dist->regen; -$dist->chdir_in; - -$mb = Module::Build->new_from_context; -is $@, ''; +$mb = $dist->new_from_context; -$mb->dispatch('build'); +eval { $mb->dispatch('build') }; is $@, ''; -$mb->dispatch('test'); +stdout_of( sub { eval { $mb->dispatch('test') } } ); is $@, ''; -$mb->dispatch('realclean'); +eval { $mb->dispatch('realclean') }; is $@, ''; -# cleanup -$dist->remove; diff --git a/cpan/Pod-Simple/ChangeLog b/cpan/Pod-Simple/ChangeLog index c36a6f1f85..8aa779da92 100644 --- a/cpan/Pod-Simple/ChangeLog +++ b/cpan/Pod-Simple/ChangeLog @@ -1,6 +1,21 @@ # ChangeLog for Pod::Simple dist #--------------------------------------------------------------------------- +2009-11-12 David E. Wheeler <david@justatheory.org> + * Release 3.10 + + Converted test files that had DOS enedings to have Unix endings + (RT #50922 from Steve Hay). + + Skip tests on VMS where the lack of filename case preservation can + wreak havoc (RT #51184 from Craig A. Berry). + + Fix nested definition list format in the XHTML output + (RT #51187 from Lars Dɪᴇᴄᴋá´á´¡). + + Added some files missing from the MANIFEST (and therefore the + distribution) in the last two releases. + 2009-10-27 Allison Randal <allison@perl.org> * Release 3.09 @@ -187,7 +202,7 @@ crazy, I've tried to basically turn off all Unicode/utf8 support under 5.6. Under 5.8 and above, Unicode should work fine, and under 5.6, all Unicode characters should be replaced with a little - "can't render" symbol, either a "¤" or a "?". + "can't render" symbol, either a "¤" or a "?". Many many thanks to Jarkko Hietaniemi for helping out. (Works under 5.005 now too?) diff --git a/cpan/Pod-Simple/lib/Pod/Simple.pm b/cpan/Pod-Simple/lib/Pod/Simple.pm index a122bf700b..ae4aaff613 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple.pm @@ -18,7 +18,7 @@ use vars qw( ); @ISA = ('Pod::Simple::BlackBox'); -$VERSION = '3.09'; +$VERSION = '3.10'; @Known_formatting_codes = qw(I B C L E F S X Z); %Known_formatting_codes = map(($_=>1), @Known_formatting_codes); diff --git a/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm b/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm index e04da3b59b..e4d66348c2 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm @@ -28,7 +28,7 @@ L<Pod::Simple::HTML>, but it largely preserves the same interface. package Pod::Simple::XHTML; use strict; use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES ); -$VERSION = '3.09'; +$VERSION = '3.10'; use Carp (); use Pod::Simple::Methody (); @ISA = ('Pod::Simple::Methody'); @@ -250,14 +250,22 @@ sub start_item_bullet { } sub start_item_text { - $_[0]{'scratch'} = "</dd>\n" if delete $_[0]{'in_dd'}; + if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) { + $_[0]{'scratch'} = "</dd>\n"; + $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0; + } $_[0]{'scratch'} .= '<dt>'; } sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; $_[0]->emit } -sub start_over_text { $_[0]{'scratch'} = '<dl>'; $_[0]->emit } sub start_over_block { $_[0]{'scratch'} = '<ul>'; $_[0]->emit } sub start_over_number { $_[0]{'scratch'} = '<ol>'; $_[0]->emit } +sub start_over_text { + $_[0]{'scratch'} = '<dl>'; + $_[0]{'dl_level'}++; + $_[0]{'in_dd'} ||= []; + $_[0]->emit +} sub end_over_block { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit } @@ -274,8 +282,12 @@ sub end_over_bullet { } sub end_over_text { - $_[0]{'scratch'} = "</dd>\n" if delete $_[0]{'in_dd'}; + if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) { + $_[0]{'scratch'} = "</dd>\n"; + $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0; + } $_[0]{'scratch'} .= '</dl>'; + $_[0]{'dl_level'}--; $_[0]->emit; } @@ -303,7 +315,12 @@ sub end_head4 { shift->_end_head(@_); } sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit } sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit } -sub end_item_text { $_[0]{'scratch'} .= "</dt>\n<dd>"; $_[0]{'in_dd'} = 1; $_[0]->emit } + +sub end_item_text { + $_[0]{'scratch'} .= "</dt>\n<dd>"; + $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1; + $_[0]->emit; +} # This handles =begin and =for blocks of all kinds. sub start_for { diff --git a/cpan/Pod-Simple/t/search20.t b/cpan/Pod-Simple/t/search20.t index 52c6c36a16..3022b3653b 100644 --- a/cpan/Pod-Simple/t/search20.t +++ b/cpan/Pod-Simple/t/search20.t @@ -69,12 +69,16 @@ print $p; { my $names = join "|", sort values %$where2name; -ok $names, "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; } { my $names = join "|", sort keys %$name2where; -ok $names, "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; } ok( ($name2where->{'squaa'} || 'huh???'), '/squaa\.pm$/'); diff --git a/cpan/Pod-Simple/t/search22.t b/cpan/Pod-Simple/t/search22.t index 05157b748c..24a91ed45e 100644 --- a/cpan/Pod-Simple/t/search22.t +++ b/cpan/Pod-Simple/t/search22.t @@ -71,13 +71,17 @@ print $p; { print "# won't show any shadows, since we're just looking at the name2where keys\n"; my $names = join "|", sort keys %$name2where; -ok $names, "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; } { print "# but here we'll see shadowing:\n"; my $names = join "|", sort values %$where2name; -ok $names, "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Glunk|hinkhonk::Vliff|hinkhonk::Vliff|perlflif|perlthng|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Vliff|squaa::Vliff|squaa::Wowo|zikzik"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Glunk|hinkhonk::Vliff|hinkhonk::Vliff|perlflif|perlthng|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Vliff|squaa::Vliff|squaa::Wowo|zikzik"; my %count; for(values %$where2name) { ++$count{$_} }; @@ -103,8 +107,9 @@ ok( ($name2where->{'perlthng'} || 'huh???'), '/[^\^]testlib1/' ); ok( ($name2where->{'squaa::Vliff'} || 'huh???'), '/[^\^]testlib1/' ); # Some sanity: -ok( ($name2where->{'squaa::Wowo'} || 'huh???'), '/testlib2/' ); - +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + ($name2where->{'squaa::Wowo'} || 'huh???'), + '/testlib2/'; diff --git a/cpan/Pod-Simple/t/search25.t b/cpan/Pod-Simple/t/search25.t index 77045033b9..610becb7ef 100644 --- a/cpan/Pod-Simple/t/search25.t +++ b/cpan/Pod-Simple/t/search25.t @@ -77,12 +77,16 @@ print $p; { my $names = join "|", sort keys %$name2where; -ok $names, "squaa::Glunk|squaa::Vliff|squaa::Wowo"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "squaa::Glunk|squaa::Vliff|squaa::Wowo"; } { my $names = join "|", sort values %$where2name; -ok $names, "squaa::Glunk|squaa::Vliff|squaa::Vliff|squaa::Vliff|squaa::Wowo"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "squaa::Glunk|squaa::Vliff|squaa::Vliff|squaa::Vliff|squaa::Wowo"; my %count; for(values %$where2name) { ++$count{$_} }; @@ -102,7 +106,9 @@ ok ! $name2where->{'squaa'}; # because squaa.pm isn't squaa::* ok( ($name2where->{'squaa::Vliff'} || 'huh???'), '/[^\^]testlib1/' ); -ok( ($name2where->{'squaa::Wowo'} || 'huh???'), '/testlib2/' ); +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + ($name2where->{'squaa::Wowo'} || 'huh???'), + '/testlib2/'; print "# OK, bye from ", __FILE__, "\n"; diff --git a/cpan/Pod-Simple/t/search27.t b/cpan/Pod-Simple/t/search27.t index 22cf32d107..7614e525c4 100644 --- a/cpan/Pod-Simple/t/search27.t +++ b/cpan/Pod-Simple/t/search27.t @@ -74,12 +74,16 @@ print $p; { my $names = join "|", sort keys %$name2where; -ok $names, "squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo"; } { my $names = join "|", sort values %$where2name; -ok $names, "squaa|squaa::Glunk|squaa::Vliff|squaa::Vliff|squaa::Vliff|squaa::Wowo"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "squaa|squaa::Glunk|squaa::Vliff|squaa::Vliff|squaa::Vliff|squaa::Wowo"; my %count; for(values %$where2name) { ++$count{$_} }; @@ -99,7 +103,9 @@ ok $name2where->{'squaa'}; # because squaa.pm IS squaa* ok( ($name2where->{'squaa::Vliff'} || 'huh???'), '/[^\^]testlib1/' ); -ok( ($name2where->{'squaa::Wowo'} || 'huh???'), '/testlib2/' ); +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + ($name2where->{'squaa::Wowo'} || 'huh???'), + '/testlib2/'; print "# OK, bye from ", __FILE__, "\n"; diff --git a/cpan/Pod-Simple/t/search50.t b/cpan/Pod-Simple/t/search50.t index 55fb8a5e01..195a8f150c 100644 --- a/cpan/Pod-Simple/t/search50.t +++ b/cpan/Pod-Simple/t/search50.t @@ -77,7 +77,10 @@ if( $testmod ) { print "# Comparing \"$x[0]\" to \"$x[1]\"\n"; for(@x) { s{[/\\]}{/}g; } print "# => \"$x[0]\" to \"$x[1]\"\n"; - ok $x[0], $x[1], " find('$testmod') should match survey's name2where{$testmod}"; + skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $x[0], + $x[1], + " find('$testmod') should match survey's name2where{$testmod}"; } else { ok 0; # no 'thatpath/<name>.pm' means can't test find() } diff --git a/cpan/Pod-Simple/t/xhtml01.t b/cpan/Pod-Simple/t/xhtml01.t index d2723904cd..8517dda699 100644 --- a/cpan/Pod-Simple/t/xhtml01.t +++ b/cpan/Pod-Simple/t/xhtml01.t @@ -8,7 +8,7 @@ BEGIN { use strict; use lib '../lib'; -use Test::More tests => 33; +use Test::More tests => 35; use_ok('Pod::Simple::XHTML') or exit; @@ -220,6 +220,109 @@ is($results, <<'EOHTML', "bulleted author list"); EOHTML +initialize($parser, $results); +$parser->parse_string_document(<<'EOPOD'); +=over + +=item Pinky + +=over + +=item World Domination + +=back + +=item Brain + +=back + +EOPOD + +is($results, <<'EOHTML', 'nested lists'); +<dl> + +<dt>Pinky</dt> +<dd> + +<dl> + +<dt>World Domination</dt> +<dd> + +</dd> +</dl> + +</dd> +<dt>Brain</dt> +<dd> + +</dd> +</dl> + +EOHTML + +initialize($parser, $results); +$parser->parse_string_document(<<'EOPOD'); +=over + +=item Pinky + +On the list: + +=over + +=item World Domination + +Fight the good fight + +=item Go to Europe + +(Steve Martin joke) + +=back + +=item Brain + +Not so much + +=back + +EOPOD + +is($results, <<'EOHTML', 'multiparagraph nested lists'); +<dl> + +<dt>Pinky</dt> +<dd> + +<p>On the list:</p> + +<dl> + +<dt>World Domination</dt> +<dd> + +<p>Fight the good fight</p> + +</dd> +<dt>Go to Europe</dt> +<dd> + +<p>(Steve Martin joke)</p> + +</dd> +</dl> + +</dd> +<dt>Brain</dt> +<dd> + +<p>Not so much</p> + +</dd> +</dl> + +EOHTML initialize($parser, $results); $parser->parse_string_document(<<'EOPOD'); diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm index fbfee981d7..93e250fd56 100644 --- a/dist/B-Deparse/Deparse.pm +++ b/dist/B-Deparse/Deparse.pm @@ -16,13 +16,14 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED + OPpREVERSE_INPLACE SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG CVf_METHOD CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED), ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'), ($] < 5.011 ? 'CVf_LOCKED' : ()); -$VERSION = 0.92; +$VERSION = 0.93; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -2308,6 +2309,9 @@ sub listop { for (; !null($kid); $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 6); } + if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) { + return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]"); + } if ($parens) { return "$name(" . join(", ", @exprs) . ")"; } else { diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t index c9c92f9ca8..191324a7c3 100644 --- a/dist/B-Deparse/t/deparse.t +++ b/dist/B-Deparse/t/deparse.t @@ -17,7 +17,7 @@ BEGIN { require feature; feature->import(':5.10'); } -use Test::More tests => 78; +use Test::More tests => 83; use Config (); use B::Deparse; @@ -591,3 +591,27 @@ foreach (0..3) { print ++$x, "\n"; } } +#### +my $pi = 4; +#### +no warnings; +my $pi := 4; +>>>> +no warnings; +my $pi = 4; +#### +my $pi : = 4; +>>>> +my $pi = 4; +#### +our @a; +my @b; +@a = sort @a; +@b = sort @b; +(); +#### +our @a; +my @b; +@a = reverse @a; +@b = reverse @b; +(); diff --git a/dist/Module-CoreList/Changes b/dist/Module-CoreList/Changes index e6dc8635e2..1ecd7d4c92 100644 --- a/dist/Module-CoreList/Changes +++ b/dist/Module-CoreList/Changes @@ -1,3 +1,6 @@ +2.23 Fri Nov 20 2009 + - Updated for 5.11.2 + 2.22 Thu Oct 22 2009 - is_deprecated function and %deprecated hash (dagolden) diff --git a/dist/Module-CoreList/META.yml b/dist/Module-CoreList/META.yml index 6ae96aa193..536f83bd79 100644 --- a/dist/Module-CoreList/META.yml +++ b/dist/Module-CoreList/META.yml @@ -1,6 +1,6 @@ --- #YAML:1.0 name: Module-CoreList -version: 2.20 +version: 2.23 abstract: ~ license: perl author: ~ diff --git a/dist/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index 123f4fafed..4fcb512180 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/dist/Module-CoreList/lib/Module/CoreList.pm @@ -2,7 +2,7 @@ package Module::CoreList; use strict; use vars qw/$VERSION %released %version %families %upstream %bug_tracker %deprecated/; -$VERSION = '2.22'; +$VERSION = '2.23'; =head1 NAME @@ -58,7 +58,7 @@ omitted, it defaults to the current version of Perl. Module::CoreList currently covers the 5.000, 5.001, 5.002, 5.003_07, 5.004, 5.004_05, 5.005, 5.005_03, 5.005_04, 5.6.0, 5.6.1, 5.6.2, 5.7.3, 5.8.0, 5.8.1, 5.8.2, 5.8.3, 5.8.4, 5.8.5, 5.8.6, 5.8.7, 5.8.8, 5.8.9, 5.9.0, 5.9.1, 5.9.2, 5.9.3, -5.9.4, 5.9.5, 5.10.0, 5.10.1, 5.11.0 and 5.11.1 releases of perl. +5.9.4, 5.9.5, 5.10.0, 5.10.1, 5.11.0, 5.11.1 and 5.11.2 releases of perl. =head1 HISTORY @@ -187,6 +187,7 @@ sub is_deprecated { 5.010001 => '2009-08-22', 5.011000 => '2009-10-02', 5.011001 => '2009-10-20', + 5.011002 => '2009-11-20', ); for my $version ( sort { $a <=> $b } keys %released ) { @@ -10905,6 +10906,630 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'warnings' => '1.07', 'warnings::register' => '1.01', }, + 5.011002 => { + 'AnyDBM_File' => '1.00', + 'App::Prove' => '3.17', + 'App::Prove::State' => '3.17', + 'App::Prove::State::Result'=> '3.17', + 'App::Prove::State::Result::Test'=> '3.17', + 'Archive::Extract' => '0.34', + 'Archive::Tar' => '1.54', + 'Archive::Tar::Constant'=> '0.02', + 'Archive::Tar::File' => '0.02', + 'Attribute::Handlers' => '0.87', + 'AutoLoader' => '5.70', + 'AutoSplit' => '1.06', + 'B' => '1.23', + 'B::Concise' => '0.78', + 'B::Debug' => '1.11', + 'B::Deparse' => '0.93', + 'B::Lint' => '1.11_01', + 'B::Lint::Debug' => '0.01', + 'B::Showlex' => '1.02', + 'B::Terse' => '1.05', + 'B::Xref' => '1.02', + 'Benchmark' => '1.11', + 'CGI' => '3.48', + 'CGI::Apache' => '1.01', + 'CGI::Carp' => '3.45', + 'CGI::Cookie' => '1.29', + 'CGI::Fast' => '1.07', + 'CGI::Pretty' => '3.46', + 'CGI::Push' => '1.04', + 'CGI::Switch' => '1.01', + 'CGI::Util' => '3.48', + 'CPAN' => '1.94_51', + 'CPAN::Author' => '5.5', + 'CPAN::Bundle' => '5.5', + 'CPAN::CacheMgr' => '5.5', + 'CPAN::Complete' => '5.5', + 'CPAN::Debug' => '5.5', + 'CPAN::DeferredCode' => '5.50', + 'CPAN::Distribution' => '1.94', + 'CPAN::Distroprefs' => '6', + 'CPAN::Distrostatus' => '5.5', + 'CPAN::Exception::RecursiveDependency'=> '5.5', + 'CPAN::Exception::blocked_urllist'=> '1.0', + 'CPAN::Exception::yaml_not_installed'=> '5.5', + 'CPAN::FTP' => '5.5002', + 'CPAN::FTP::netrc' => '1.00', + 'CPAN::FirstTime' => '5.53', + 'CPAN::HandleConfig' => '5.5', + 'CPAN::Index' => '1.94', + 'CPAN::InfoObj' => '5.5', + 'CPAN::Kwalify' => '5.50', + 'CPAN::LWP::UserAgent' => '1.94', + 'CPAN::Module' => '5.5', + 'CPAN::Nox' => '5.50', + 'CPAN::Prompt' => '5.5', + 'CPAN::Queue' => '5.5', + 'CPAN::Shell' => '5.5', + 'CPAN::Tarzip' => '5.501', + 'CPAN::URL' => '5.5', + 'CPAN::Version' => '5.5', + 'CPANPLUS' => '0.89_09', + 'CPANPLUS::Backend' => undef, + 'CPANPLUS::Backend::RV' => undef, + 'CPANPLUS::Config' => undef, + 'CPANPLUS::Configure' => undef, + 'CPANPLUS::Configure::Setup'=> undef, + 'CPANPLUS::Dist' => undef, + 'CPANPLUS::Dist::Autobundle'=> undef, + 'CPANPLUS::Dist::Base' => undef, + 'CPANPLUS::Dist::Build' => '0.44', + 'CPANPLUS::Dist::Build::Constants'=> '0.44', + 'CPANPLUS::Dist::MM' => undef, + 'CPANPLUS::Dist::Sample'=> undef, + 'CPANPLUS::Error' => undef, + 'CPANPLUS::Internals' => '0.89_09', + 'CPANPLUS::Internals::Constants'=> undef, + 'CPANPLUS::Internals::Constants::Report'=> undef, + 'CPANPLUS::Internals::Extract'=> undef, + 'CPANPLUS::Internals::Fetch'=> undef, + 'CPANPLUS::Internals::Report'=> undef, + 'CPANPLUS::Internals::Search'=> undef, + 'CPANPLUS::Internals::Source'=> undef, + 'CPANPLUS::Internals::Source::Memory'=> undef, + 'CPANPLUS::Internals::Source::SQLite'=> undef, + 'CPANPLUS::Internals::Source::SQLite::Tie'=> undef, + 'CPANPLUS::Internals::Utils'=> undef, + 'CPANPLUS::Internals::Utils::Autoflush'=> undef, + 'CPANPLUS::Module' => undef, + 'CPANPLUS::Module::Author'=> undef, + 'CPANPLUS::Module::Author::Fake'=> undef, + 'CPANPLUS::Module::Checksums'=> undef, + 'CPANPLUS::Module::Fake'=> undef, + 'CPANPLUS::Module::Signature'=> undef, + 'CPANPLUS::Selfupdate' => undef, + 'CPANPLUS::Shell' => undef, + 'CPANPLUS::Shell::Classic'=> '0.0562', + 'CPANPLUS::Shell::Default'=> '0.89_09', + 'CPANPLUS::Shell::Default::Plugins::CustomSource'=> undef, + 'CPANPLUS::Shell::Default::Plugins::Remote'=> undef, + 'CPANPLUS::Shell::Default::Plugins::Source'=> undef, + 'Carp' => '1.14', + 'Carp::Heavy' => '1.14', + 'Class::ISA' => '0.36', + 'Class::Struct' => '0.63', + 'Compress::Raw::Bzip2' => '2.021', + 'Compress::Raw::Zlib' => '2.021', + 'Compress::Zlib' => '2.022', + 'Config' => undef, + 'Config::Extensions' => '0.01', + 'Cwd' => '3.3002', + 'DB' => '1.02', + 'DBM_Filter' => '0.03', + 'DBM_Filter::compress' => '0.02', + 'DBM_Filter::encode' => '0.02', + 'DBM_Filter::int32' => '0.02', + 'DBM_Filter::null' => '0.02', + 'DBM_Filter::utf8' => '0.02', + 'DB_File' => '1.820', + 'Data::Dumper' => '2.125', + 'Devel::DProf' => '20080331.00', + 'Devel::DProf::dprof::V'=> undef, + 'Devel::InnerPackage' => '0.3', + 'Devel::PPPort' => '3.19', + 'Devel::Peek' => '1.04', + 'Devel::SelfStubber' => '1.03', + 'Digest' => '1.16', + 'Digest::MD5' => '2.39', + 'Digest::SHA' => '5.47', + 'Digest::base' => '1.16', + 'Digest::file' => '1.16', + 'DirHandle' => '1.03', + 'Dumpvalue' => '1.13', + 'DynaLoader' => '1.10', + 'Encode' => '2.38', + 'Encode::Alias' => '2.12', + 'Encode::Byte' => '2.04', + 'Encode::CJKConstants' => '2.02', + 'Encode::CN' => '2.03', + 'Encode::CN::HZ' => '2.05', + 'Encode::Config' => '2.05', + 'Encode::EBCDIC' => '2.02', + 'Encode::Encoder' => '2.01', + 'Encode::Encoding' => '2.05', + 'Encode::GSM0338' => '2.01', + 'Encode::Guess' => '2.03', + 'Encode::JP' => '2.04', + 'Encode::JP::H2Z' => '2.02', + 'Encode::JP::JIS7' => '2.04', + 'Encode::KR' => '2.03', + 'Encode::KR::2022_KR' => '2.02', + 'Encode::MIME::Header' => '2.11', + 'Encode::MIME::Header::ISO_2022_JP'=> '1.03', + 'Encode::MIME::Name' => '1.01', + 'Encode::Symbol' => '2.02', + 'Encode::TW' => '2.03', + 'Encode::Unicode' => '2.07', + 'Encode::Unicode::UTF7' => '2.04', + 'English' => '1.04', + 'Env' => '1.01', + 'Errno' => '1.11', + 'Exporter' => '5.64_01', + 'Exporter::Heavy' => '5.64_01', + 'ExtUtils::CBuilder' => '0.27', + 'ExtUtils::CBuilder::Base'=> '0.27', + 'ExtUtils::CBuilder::Platform::Unix'=> '0.27', + 'ExtUtils::CBuilder::Platform::VMS'=> '0.27', + 'ExtUtils::CBuilder::Platform::Windows'=> '0.27', + 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.27', + 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.27', + 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.27', + 'ExtUtils::CBuilder::Platform::aix'=> '0.27', + 'ExtUtils::CBuilder::Platform::cygwin'=> '0.27', + 'ExtUtils::CBuilder::Platform::darwin'=> '0.27', + 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.27', + 'ExtUtils::CBuilder::Platform::os2'=> '0.27', + 'ExtUtils::Command' => '1.16', + 'ExtUtils::Command::MM' => '6.55_02', + 'ExtUtils::Constant' => '0.22', + 'ExtUtils::Constant::Base'=> '0.04', + 'ExtUtils::Constant::ProxySubs'=> '0.06', + 'ExtUtils::Constant::Utils'=> '0.02', + 'ExtUtils::Constant::XS'=> '0.03', + 'ExtUtils::Embed' => '1.28', + 'ExtUtils::Install' => '1.55', + 'ExtUtils::Installed' => '1.999_001', + 'ExtUtils::Liblist' => '6.55_02', + 'ExtUtils::Liblist::Kid'=> '6.5502', + 'ExtUtils::MM' => '6.55_02', + 'ExtUtils::MM_AIX' => '6.55_02', + 'ExtUtils::MM_Any' => '6.55_02', + 'ExtUtils::MM_BeOS' => '6.55_02', + 'ExtUtils::MM_Cygwin' => '6.55_02', + 'ExtUtils::MM_DOS' => '6.5502', + 'ExtUtils::MM_Darwin' => '6.55_02', + 'ExtUtils::MM_MacOS' => '6.5502', + 'ExtUtils::MM_NW5' => '6.55_02', + 'ExtUtils::MM_OS2' => '6.55_02', + 'ExtUtils::MM_QNX' => '6.55_02', + 'ExtUtils::MM_UWIN' => '6.5502', + 'ExtUtils::MM_Unix' => '6.55_02', + 'ExtUtils::MM_VMS' => '6.55_02', + 'ExtUtils::MM_VOS' => '6.55_02', + 'ExtUtils::MM_Win32' => '6.55_02', + 'ExtUtils::MM_Win95' => '6.55_02', + 'ExtUtils::MY' => '6.5502', + 'ExtUtils::MakeMaker' => '6.55_02', + 'ExtUtils::MakeMaker::Config'=> '6.55_02', + 'ExtUtils::Manifest' => '1.57', + 'ExtUtils::Miniperl' => undef, + 'ExtUtils::Mkbootstrap' => '6.55_02', + 'ExtUtils::Mksymlists' => '6.55_02', + 'ExtUtils::Packlist' => '1.44', + 'ExtUtils::ParseXS' => '2.21', + 'ExtUtils::XSSymSet' => '1.1', + 'ExtUtils::testlib' => '6.5502', + 'Fatal' => '2.06_01', + 'Fcntl' => '1.06', + 'File::Basename' => '2.78', + 'File::CheckTree' => '4.4', + 'File::Compare' => '1.1006', + 'File::Copy' => '2.16', + 'File::DosGlob' => '1.01', + 'File::Fetch' => '0.22', + 'File::Find' => '1.14', + 'File::Glob' => '1.07', + 'File::GlobMapper' => '1.000', + 'File::Path' => '2.08', + 'File::Spec' => '3.30', + 'File::Spec::Cygwin' => '3.30', + 'File::Spec::Epoc' => '3.30', + 'File::Spec::Functions' => '3.30', + 'File::Spec::Mac' => '3.30', + 'File::Spec::OS2' => '3.30', + 'File::Spec::Unix' => '3.30', + 'File::Spec::VMS' => '3.30', + 'File::Spec::Win32' => '3.30', + 'File::Temp' => '0.22', + 'File::stat' => '1.02', + 'FileCache' => '1.08', + 'FileHandle' => '2.02', + 'Filespec' => '1.12', + 'Filter::Simple' => '0.84', + 'Filter::Util::Call' => '1.08', + 'FindBin' => '1.50', + 'GDBM_File' => '1.09', + 'Getopt::Long' => '2.38', + 'Getopt::Std' => '1.06', + 'Hash::Util' => '0.07', + 'Hash::Util::FieldHash' => '1.04', + 'I18N::Collate' => '1.01', + 'I18N::LangTags' => '0.35', + 'I18N::LangTags::Detect'=> '1.04', + 'I18N::LangTags::List' => '0.35', + 'I18N::Langinfo' => '0.03', + 'IO' => '1.25_02', + 'IO::Compress::Adapter::Bzip2'=> '2.022', + 'IO::Compress::Adapter::Deflate'=> '2.022', + 'IO::Compress::Adapter::Identity'=> '2.022', + 'IO::Compress::Base' => '2.022', + 'IO::Compress::Base::Common'=> '2.022', + 'IO::Compress::Bzip2' => '2.022', + 'IO::Compress::Deflate' => '2.022', + 'IO::Compress::Gzip' => '2.022', + 'IO::Compress::Gzip::Constants'=> '2.022', + 'IO::Compress::RawDeflate'=> '2.022', + 'IO::Compress::Zip' => '2.022', + 'IO::Compress::Zip::Constants'=> '2.022', + 'IO::Compress::Zlib::Constants'=> '2.022', + 'IO::Compress::Zlib::Extra'=> '2.022', + 'IO::Dir' => '1.07', + 'IO::File' => '1.14', + 'IO::Handle' => '1.28', + 'IO::Pipe' => '1.13', + 'IO::Poll' => '0.07', + 'IO::Seekable' => '1.10', + 'IO::Select' => '1.17', + 'IO::Socket' => '1.31', + 'IO::Socket::INET' => '1.31', + 'IO::Socket::UNIX' => '1.23', + 'IO::Uncompress::Adapter::Bunzip2'=> '2.022', + 'IO::Uncompress::Adapter::Identity'=> '2.022', + 'IO::Uncompress::Adapter::Inflate'=> '2.022', + 'IO::Uncompress::AnyInflate'=> '2.022', + 'IO::Uncompress::AnyUncompress'=> '2.022', + 'IO::Uncompress::Base' => '2.022', + 'IO::Uncompress::Bunzip2'=> '2.022', + 'IO::Uncompress::Gunzip'=> '2.022', + 'IO::Uncompress::Inflate'=> '2.022', + 'IO::Uncompress::RawInflate'=> '2.022', + 'IO::Uncompress::Unzip' => '2.022', + 'IO::Zlib' => '1.10', + 'IPC::Cmd' => '0.54', + 'IPC::Msg' => '2.01', + 'IPC::Open2' => '1.03', + 'IPC::Open3' => '1.05', + 'IPC::Semaphore' => '2.01', + 'IPC::SharedMem' => '2.01', + 'IPC::SysV' => '2.01', + 'List::Util' => '1.22', + 'List::Util::PP' => '1.22', + 'List::Util::XS' => '1.22', + 'Locale::Constants' => '2.07', + 'Locale::Country' => '2.07', + 'Locale::Currency' => '2.07', + 'Locale::Language' => '2.07', + 'Locale::Maketext' => '1.14', + 'Locale::Maketext::Guts'=> '1.13', + 'Locale::Maketext::GutsLoader'=> '1.13', + 'Locale::Maketext::Simple'=> '0.21', + 'Locale::Script' => '2.07', + 'Log::Message' => '0.02', + 'Log::Message::Config' => '0.01', + 'Log::Message::Handlers'=> undef, + 'Log::Message::Item' => undef, + 'Log::Message::Simple' => '0.06', + 'MIME::Base64' => '3.08', + 'MIME::QuotedPrint' => '3.08', + 'Math::BigFloat' => '1.60', + 'Math::BigFloat::Trace' => '0.01', + 'Math::BigInt' => '1.89_01', + 'Math::BigInt::Calc' => '0.52', + 'Math::BigInt::CalcEmu' => '0.05', + 'Math::BigInt::FastCalc'=> '0.19', + 'Math::BigInt::Trace' => '0.01', + 'Math::BigRat' => '0.24', + 'Math::Complex' => '1.56', + 'Math::Trig' => '1.2', + 'Memoize' => '1.01_03', + 'Memoize::AnyDBM_File' => '0.65', + 'Memoize::Expire' => '1.00', + 'Memoize::ExpireFile' => '1.01', + 'Memoize::ExpireTest' => '0.65', + 'Memoize::NDBM_File' => '0.65', + 'Memoize::SDBM_File' => '0.65', + 'Memoize::Storable' => '0.65', + 'Module::Build' => '0.35_09', + 'Module::Build::Base' => '0.35_09', + 'Module::Build::Compat' => '0.35_09', + 'Module::Build::Config' => '0.35_09', + 'Module::Build::ConfigData'=> undef, + 'Module::Build::Cookbook'=> '0.35_09', + 'Module::Build::Dumper' => '0.35_09', + 'Module::Build::ModuleInfo'=> '0.35_09', + 'Module::Build::Notes' => '0.35_09', + 'Module::Build::PPMMaker'=> '0.35_09', + 'Module::Build::Platform::Amiga'=> '0.35_09', + 'Module::Build::Platform::Default'=> '0.35_09', + 'Module::Build::Platform::EBCDIC'=> '0.35_09', + 'Module::Build::Platform::MPEiX'=> '0.35_09', + 'Module::Build::Platform::MacOS'=> '0.35_09', + 'Module::Build::Platform::RiscOS'=> '0.35_09', + 'Module::Build::Platform::Unix'=> '0.35_09', + 'Module::Build::Platform::VMS'=> '0.35_09', + 'Module::Build::Platform::VOS'=> '0.35_09', + 'Module::Build::Platform::Windows'=> '0.35_09', + 'Module::Build::Platform::aix'=> '0.35_09', + 'Module::Build::Platform::cygwin'=> '0.35_09', + 'Module::Build::Platform::darwin'=> '0.35_09', + 'Module::Build::Platform::os2'=> '0.35_09', + 'Module::Build::PodParser'=> '0.35_09', + 'Module::Build::Version'=> '0.77', + 'Module::Build::YAML' => '1.40', + 'Module::CoreList' => '2.23', + 'Module::Load' => '0.16', + 'Module::Load::Conditional'=> '0.34', + 'Module::Loaded' => '0.06', + 'Module::Pluggable' => '3.9', + 'Module::Pluggable::Object'=> '3.9', + 'Moped::Msg' => '0.01', + 'NDBM_File' => '1.08', + 'NEXT' => '0.64', + 'Net::Cmd' => '2.29', + 'Net::Config' => '1.11', + 'Net::Domain' => '2.20', + 'Net::FTP' => '2.77', + 'Net::FTP::A' => '1.18', + 'Net::FTP::E' => '0.01', + 'Net::FTP::I' => '1.12', + 'Net::FTP::L' => '0.01', + 'Net::FTP::dataconn' => '0.11', + 'Net::NNTP' => '2.24', + 'Net::Netrc' => '2.12', + 'Net::POP3' => '2.29', + 'Net::Ping' => '2.36', + 'Net::SMTP' => '2.31', + 'Net::Time' => '2.10', + 'Net::hostent' => '1.01', + 'Net::netent' => '1.00', + 'Net::protoent' => '1.00', + 'Net::servent' => '1.01', + 'O' => '1.01', + 'ODBM_File' => '1.07', + 'Object::Accessor' => '0.36', + 'Opcode' => '1.15', + 'POSIX' => '1.18', + 'Package::Constants' => '0.02', + 'Params::Check' => '0.26', + 'Parse::CPAN::Meta' => '1.40', + 'PerlIO' => '1.06', + 'PerlIO::encoding' => '0.11', + 'PerlIO::scalar' => '0.07', + 'PerlIO::via' => '0.09', + 'PerlIO::via::QuotedPrint'=> '0.06', + 'Pod::Checker' => '1.45', + 'Pod::Escapes' => '1.04', + 'Pod::Find' => '1.35', + 'Pod::Functions' => '1.03', + 'Pod::Html' => '1.09', + 'Pod::InputObjects' => '1.31', + 'Pod::LaTeX' => '0.58', + 'Pod::Man' => '2.22', + 'Pod::ParseLink' => '1.09', + 'Pod::ParseUtils' => '1.36', + 'Pod::Parser' => '1.37', + 'Pod::Perldoc' => '3.15_01', + 'Pod::Perldoc::BaseTo' => undef, + 'Pod::Perldoc::GetOptsOO'=> undef, + 'Pod::Perldoc::ToChecker'=> undef, + 'Pod::Perldoc::ToMan' => undef, + 'Pod::Perldoc::ToNroff' => undef, + 'Pod::Perldoc::ToPod' => undef, + 'Pod::Perldoc::ToRtf' => undef, + 'Pod::Perldoc::ToText' => undef, + 'Pod::Perldoc::ToTk' => undef, + 'Pod::Perldoc::ToXml' => undef, + 'Pod::PlainText' => '2.04', + 'Pod::Plainer' => '1.01', + 'Pod::Select' => '1.36', + 'Pod::Simple' => '3.10', + 'Pod::Simple::BlackBox' => undef, + 'Pod::Simple::Checker' => '2.02', + 'Pod::Simple::Debug' => undef, + 'Pod::Simple::DumpAsText'=> '2.02', + 'Pod::Simple::DumpAsXML'=> '2.02', + 'Pod::Simple::HTML' => '3.03', + 'Pod::Simple::HTMLBatch'=> '3.02', + 'Pod::Simple::HTMLLegacy'=> '5.01', + 'Pod::Simple::LinkSection'=> undef, + 'Pod::Simple::Methody' => '2.02', + 'Pod::Simple::Progress' => '1.01', + 'Pod::Simple::PullParser'=> '2.02', + 'Pod::Simple::PullParserEndToken'=> undef, + 'Pod::Simple::PullParserStartToken'=> undef, + 'Pod::Simple::PullParserTextToken'=> undef, + 'Pod::Simple::PullParserToken'=> '2.02', + 'Pod::Simple::RTF' => '2.02', + 'Pod::Simple::Search' => '3.04', + 'Pod::Simple::SimpleTree'=> '2.02', + 'Pod::Simple::Text' => '2.02', + 'Pod::Simple::TextContent'=> '2.02', + 'Pod::Simple::TiedOutFH'=> undef, + 'Pod::Simple::Transcode'=> undef, + 'Pod::Simple::TranscodeDumb'=> '2.02', + 'Pod::Simple::TranscodeSmart'=> undef, + 'Pod::Simple::XHTML' => '3.10', + 'Pod::Simple::XMLOutStream'=> '2.02', + 'Pod::Text' => '3.13', + 'Pod::Text::Color' => '2.05', + 'Pod::Text::Overstrike' => '2.03', + 'Pod::Text::Termcap' => '2.05', + 'Pod::Usage' => '1.36', + 'SDBM_File' => '1.06', + 'Safe' => '2.19', + 'Scalar::Util' => '1.22', + 'Scalar::Util::PP' => '1.22', + 'Search::Dict' => '1.02', + 'SelectSaver' => '1.02', + 'SelfLoader' => '1.17', + 'Shell' => '0.72_01', + 'Simple' => '0.01', + 'Socket' => '1.85', + 'Storable' => '2.22', + 'Switch' => '2.16', + 'Symbol' => '1.07', + 'Sys::Hostname' => '1.11', + 'Sys::Syslog' => '0.27', + 'Sys::Syslog::win32::Win32'=> undef, + 'TAP::Base' => '3.17', + 'TAP::Formatter::Base' => '3.17', + 'TAP::Formatter::Color' => '3.17', + 'TAP::Formatter::Console'=> '3.17', + 'TAP::Formatter::Console::ParallelSession'=> '3.17', + 'TAP::Formatter::Console::Session'=> '3.17', + 'TAP::Formatter::File' => '3.17', + 'TAP::Formatter::File::Session'=> '3.17', + 'TAP::Formatter::Session'=> '3.17', + 'TAP::Harness' => '3.17', + 'TAP::Object' => '3.17', + 'TAP::Parser' => '3.17', + 'TAP::Parser::Aggregator'=> '3.17', + 'TAP::Parser::Grammar' => '3.17', + 'TAP::Parser::Iterator' => '3.17', + 'TAP::Parser::Iterator::Array'=> '3.17', + 'TAP::Parser::Iterator::Process'=> '3.17', + 'TAP::Parser::Iterator::Stream'=> '3.17', + 'TAP::Parser::IteratorFactory'=> '3.17', + 'TAP::Parser::Multiplexer'=> '3.17', + 'TAP::Parser::Result' => '3.17', + 'TAP::Parser::Result::Bailout'=> '3.17', + 'TAP::Parser::Result::Comment'=> '3.17', + 'TAP::Parser::Result::Plan'=> '3.17', + 'TAP::Parser::Result::Pragma'=> '3.17', + 'TAP::Parser::Result::Test'=> '3.17', + 'TAP::Parser::Result::Unknown'=> '3.17', + 'TAP::Parser::Result::Version'=> '3.17', + 'TAP::Parser::Result::YAML'=> '3.17', + 'TAP::Parser::ResultFactory'=> '3.17', + 'TAP::Parser::Scheduler'=> '3.17', + 'TAP::Parser::Scheduler::Job'=> '3.17', + 'TAP::Parser::Scheduler::Spinner'=> '3.17', + 'TAP::Parser::Source' => '3.17', + 'TAP::Parser::Source::Perl'=> '3.17', + 'TAP::Parser::Utils' => '3.17', + 'TAP::Parser::YAMLish::Reader'=> '3.17', + 'TAP::Parser::YAMLish::Writer'=> '3.17', + 'Term::ANSIColor' => '2.02', + 'Term::Cap' => '1.12', + 'Term::Complete' => '1.402', + 'Term::ReadLine' => '1.05', + 'Term::UI' => '0.20', + 'Term::UI::History' => undef, + 'Test' => '1.25_02', + 'Test::Builder' => '0.94', + 'Test::Builder::Module' => '0.94', + 'Test::Builder::Tester' => '1.18', + 'Test::Builder::Tester::Color'=> '1.18', + 'Test::Harness' => '3.17', + 'Test::More' => '0.94', + 'Test::Simple' => '0.94', + 'Text::Abbrev' => '1.01', + 'Text::Balanced' => '2.02', + 'Text::ParseWords' => '3.27', + 'Text::Soundex' => '3.03_01', + 'Text::Tabs' => '2009.0305', + 'Text::Wrap' => '2009.0305', + 'Thread' => '3.02', + 'Thread::Queue' => '2.11', + 'Thread::Semaphore' => '2.09', + 'Tie::Array' => '1.03', + 'Tie::File' => '0.97_02', + 'Tie::Handle' => '4.2', + 'Tie::Hash' => '1.03', + 'Tie::Hash::NamedCapture'=> '0.06', + 'Tie::Memoize' => '1.1', + 'Tie::RefHash' => '1.38', + 'Tie::Scalar' => '1.01', + 'Tie::StdHandle' => '4.2', + 'Tie::SubstrHash' => '1.00', + 'Time::HiRes' => '1.9719', + 'Time::Local' => '1.1901_01', + 'Time::Piece' => '1.15', + 'Time::Piece::Seconds' => undef, + 'Time::Seconds' => undef, + 'Time::gmtime' => '1.03', + 'Time::localtime' => '1.02', + 'Time::tm' => '1.00', + 'UNIVERSAL' => '1.05', + 'Unicode' => '5.1.0', + 'Unicode::Collate' => '0.52_01', + 'Unicode::Normalize' => '1.03', + 'Unicode::UCD' => '0.27', + 'User::grent' => '1.01', + 'User::pwent' => '1.00', + 'VMS::DCLsym' => '1.03', + 'VMS::Stdio' => '2.4', + 'Win32' => '0.39', + 'Win32API::File' => '0.1101', + 'Win32API::File::ExtUtils::Myconst2perl'=> '1', + 'Win32CORE' => '0.02', + 'XS::APItest' => '0.17', + 'XS::APItest::KeywordRPN'=> '0.003', + 'XS::Typemap' => '0.03', + 'XSLoader' => '0.10', + 'XSLoader::XSLoader' => '0.10', + 'attributes' => '0.12', + 'autodie' => '2.06_01', + 'autodie::exception' => '2.06_01', + 'autodie::exception::system'=> '2.06_01', + 'autodie::hints' => '2.06_01', + 'autouse' => '1.06', + 'base' => '2.15', + 'bigint' => '0.23', + 'bignum' => '0.23', + 'bigrat' => '0.23', + 'blib' => '1.04', + 'bytes' => '1.03', + 'charnames' => '1.07', + 'constant' => '1.19', + 'deprecate' => '0.01', + 'diagnostics' => '1.18', + 'encoding' => '2.6_01', + 'encoding::warnings' => '0.11', + 'feature' => '1.13', + 'fields' => '2.15', + 'filetest' => '1.02', + 'if' => '0.05', + 'inc::latest' => '0.35_09', + 'integer' => '1.00', + 'legacy' => '1.00', + 'less' => '0.02', + 'lib' => '0.62', + 'locale' => '1.00', + 'mro' => '1.02', + 'open' => '1.07', + 'ops' => '1.02', + 'overload' => '1.10', + 'overload::numbers' => undef, + 'overloading' => '0.01', + 'parent' => '0.223', + 're' => '0.10', + 'sigtrap' => '1.04', + 'sort' => '2.01', + 'strict' => '1.04', + 'subs' => '1.00', + 'threads' => '1.74', + 'threads::shared' => '1.32', + 'utf8' => '1.07', + 'vars' => '1.01', + 'version' => '0.77', + 'vmsish' => '1.02', + 'warnings' => '1.07', + 'warnings::register' => '1.01', + }, ); %deprecated = ( @@ -10920,6 +11545,12 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'Shell' => '1', 'Switch' => '1', }, + 5.011002 => { + 'Class::ISA' => '1', + 'Pod::Plainer' => '1', + 'Shell' => '1', + 'Switch' => '1', + }, ); %upstream = ( @@ -11061,6 +11692,9 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'ExtUtils::CBuilder::Platform::Unix'=> 'cpan', 'ExtUtils::CBuilder::Platform::VMS'=> 'cpan', 'ExtUtils::CBuilder::Platform::Windows'=> 'cpan', + 'ExtUtils::CBuilder::Platform::Windows::BCC'=> 'cpan', + 'ExtUtils::CBuilder::Platform::Windows::GCC'=> 'cpan', + 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> 'cpan', 'ExtUtils::CBuilder::Platform::aix'=> 'cpan', 'ExtUtils::CBuilder::Platform::cygwin'=> 'cpan', 'ExtUtils::CBuilder::Platform::darwin'=> 'cpan', @@ -11303,6 +11937,7 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'Scalar::Util::PP' => undef, 'SelfLoader' => 'blead', 'Shell' => undef, + 'Simple' => 'cpan', 'Storable' => 'blead', 'Switch' => 'blead', 'Sys::Syslog' => 'cpan', @@ -11378,6 +12013,7 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'Win32API::File' => 'cpan', 'Win32API::File::ExtUtils::Myconst2perl'=> 'cpan', 'Win32CORE' => undef, + 'XS::APItest::KeywordRPN'=> 'blead', 'XSLoader' => 'blead', 'XSLoader::XSLoader' => 'blead', 'autodie' => 'cpan', @@ -11393,6 +12029,7 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'encoding::warnings' => undef, 'fields' => 'blead', 'if' => undef, + 'inc::latest' => 'cpan', 'lib' => 'blead', 'parent' => undef, 'threads' => 'blead', @@ -11538,6 +12175,9 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'ExtUtils::CBuilder::Platform::Unix'=> undef, 'ExtUtils::CBuilder::Platform::VMS'=> undef, 'ExtUtils::CBuilder::Platform::Windows'=> undef, + 'ExtUtils::CBuilder::Platform::Windows::BCC'=> undef, + 'ExtUtils::CBuilder::Platform::Windows::GCC'=> undef, + 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> undef, 'ExtUtils::CBuilder::Platform::aix'=> undef, 'ExtUtils::CBuilder::Platform::cygwin'=> undef, 'ExtUtils::CBuilder::Platform::darwin'=> undef, @@ -11780,6 +12420,7 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'Scalar::Util::PP' => undef, 'SelfLoader' => undef, 'Shell' => undef, + 'Simple' => undef, 'Storable' => undef, 'Switch' => undef, 'Sys::Syslog' => undef, @@ -11852,6 +12493,7 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'Win32' => undef, 'Win32API::File' => undef, 'Win32API::File::ExtUtils::Myconst2perl'=> undef, + 'XS::APItest::KeywordRPN'=> undef, 'XSLoader' => undef, 'XSLoader::XSLoader' => undef, 'autodie' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', @@ -11867,6 +12509,7 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'encoding::warnings' => undef, 'fields' => undef, 'if' => undef, + 'inc::latest' => undef, 'lib' => undef, 'parent' => undef, 'threads' => undef, diff --git a/dist/threads/Makefile.PL b/dist/threads/Makefile.PL index b251797a42..cc70b658a0 100755 --- a/dist/threads/Makefile.PL +++ b/dist/threads/Makefile.PL @@ -80,7 +80,7 @@ WriteMakefile( 'PM' => { 'threads.pm' => '$(INST_LIBDIR)/threads.pm', }, - 'INSTALLDIRS' => 'perl', + 'INSTALLDIRS' => (($] < 5.011) ? 'perl' : 'site'), ((ExtUtils::MakeMaker->VERSION() lt '6.25') ? ('PL_FILES' => { }) : ()), diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t index 34f248a4db..bb1cec0d5b 100644 --- a/dist/threads/t/exit.t +++ b/dist/threads/t/exit.t @@ -48,7 +48,7 @@ my $rc = $thr->join(); ok(! defined($rc), 'Exited: threads->exit()'); -run_perl(prog => 'use threads 1.74;' . +run_perl(prog => 'use threads 1.75;' . 'threads->exit(86);' . 'exit(99);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -98,7 +98,7 @@ $rc = $thr->join(); ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); -run_perl(prog => 'use threads 1.74 qw(exit thread_only);' . +run_perl(prog => 'use threads 1.75 qw(exit thread_only);' . 'threads->create(sub { exit(99); })->join();' . 'exit(86);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -108,7 +108,7 @@ run_perl(prog => 'use threads 1.74 qw(exit thread_only);' . is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); } -my $out = run_perl(prog => 'use threads 1.74;' . +my $out = run_perl(prog => 'use threads 1.75;' . 'threads->create(sub {' . ' exit(99);' . '});' . @@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 1.74;' . like($out, '1 finished and unjoined', "exit(status) in thread"); -$out = run_perl(prog => 'use threads 1.74 qw(exit thread_only);' . +$out = run_perl(prog => 'use threads 1.75 qw(exit thread_only);' . 'threads->create(sub {' . ' threads->set_thread_exit_only(0);' . ' exit(99);' . @@ -141,7 +141,7 @@ $out = run_perl(prog => 'use threads 1.74 qw(exit thread_only);' . like($out, '1 finished and unjoined', "set_thread_exit_only(0)"); -run_perl(prog => 'use threads 1.74;' . +run_perl(prog => 'use threads 1.75;' . 'threads->create(sub {' . ' $SIG{__WARN__} = sub { exit(99); };' . ' die();' . diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t index b980c625c0..6f33cd4256 100644 --- a/dist/threads/t/thread.t +++ b/dist/threads/t/thread.t @@ -161,7 +161,7 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 1.74;' . +run_perl(prog => 'use threads 1.75;' . 'sub a{threads->create(shift)} $t = a sub{};' . '$t->tid; $t->join; $t->tid', nolib => ($ENV{PERL_CORE}) ? 0 : 1, diff --git a/dist/threads/threads.pm b/dist/threads/threads.pm index 8b9b2d8990..4552e50959 100644 --- a/dist/threads/threads.pm +++ b/dist/threads/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.74'; +our $VERSION = '1.75'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -134,7 +134,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.74 +This document describes threads version 1.75 =head1 SYNOPSIS @@ -1021,7 +1021,7 @@ L<threads> Discussion Forum on CPAN: L<http://www.cpanforum.com/dist/threads> Annotated POD for L<threads>: -L<http://annocpan.org/~JDHEDDEN/threads-1.74/threads.pm> +L<http://annocpan.org/~JDHEDDEN/threads-1.75/threads.pm> Source repository: L<http://code.google.com/p/threads-shared/> diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs index 7d0ad23c31..9e602a1bf4 100755 --- a/dist/threads/threads.xs +++ b/dist/threads/threads.xs @@ -1,11 +1,17 @@ #define PERL_NO_GET_CONTEXT +/* Workaround for mingw 32-bit compiler by mingw-w64.sf.net - has to come before any #include. + * It also defines USE_NO_MINGW_SETJMP_TWO_ARGS for the mingw.org 32-bit compilers ... but + * that's ok as that compiler makes no use of that symbol anyway */ +#if defined(WIN32) && defined(__MINGW32__) && !defined(__MINGW64__) +# define USE_NO_MINGW_SETJMP_TWO_ARGS 1 +#endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* Workaround for XSUB.h bug under WIN32 */ #ifdef WIN32 # undef setjmp -# if !defined(__BORLANDC__) +# if defined(USE_NO_MINGW_SETJMP_TWO_ARGS) || (!defined(__BORLANDC__) && !defined(__MINGW64__)) # define setjmp(x) _setjmp(x) # endif #endif @@ -674,8 +680,10 @@ S_ithread_create( ithread *thread; ithread *current_thread = S_ithread_get(aTHX); +#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 SV **tmps_tmp = PL_tmps_stack; IV tmps_ix = PL_tmps_ix; +#endif #ifndef WIN32 int rc_stack_size = 0; int rc_thread_create = 0; @@ -781,12 +789,13 @@ S_ithread_create( sv_copypv(thread->init_function, init_function); } else { thread->init_function = - SvREFCNT_inc(sv_dup(init_function, &clone_param)); + SvREFCNT_inc(sv_dup(init_function, &clone_param)); } thread->params = sv_dup(params, &clone_param); SvREFCNT_inc_void(thread->params); +#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 /* The code below checks that anything living on the tmps stack and * has been cloned (so it lives in the ptr_table) has a refcount * higher than 0. @@ -799,7 +808,7 @@ S_ithread_create( * Example of this can be found in bugreport 15837 where calls in the * parameter list end up as a temp. * - * One could argue that this fix should be in perl_clone. + * As of 5.8.8 this is done in perl_clone. */ while (tmps_ix > 0) { SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); @@ -809,6 +818,7 @@ S_ithread_create( SvREFCNT_dec(sv); } } +#endif SvTEMP_off(thread->init_function); ptr_table_free(PL_ptr_table); diff --git a/djgpp/config.over b/djgpp/config.over index f385f55369..5d97c85725 100644 --- a/djgpp/config.over +++ b/djgpp/config.over @@ -46,6 +46,7 @@ repair() -e 's=cwd=Cwd=' \ -e 's=perlio/via=PerlIO/via=' \ -e 's=perlio/encoding=PerlIO/encoding=' \ + -e 's=xs/apitest/keywordrpn=XS/APItest/KeywordRPN=' \ -e 's=xs/apitest=XS/APItest=' \ -e 's=xs/typemap=XS/Typemap=' \ -e 's=unicode/normaliz=Unicode/Normalize=' \ @@ -1191,8 +1191,7 @@ Perl_do_chomp(pTHX_ register SV *sv) } nope: - if (svrecode) - SvREFCNT_dec(svrecode); + SvREFCNT_dec(svrecode); Safefree(temp_buffer); return count; @@ -1467,8 +1466,7 @@ Perl_do_kv(pTHX) } LvTYPE(TARG) = 'k'; if (LvTARG(TARG) != (const SV *)keys) { - if (LvTARG(TARG)) - SvREFCNT_dec(LvTARG(TARG)); + SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc_simple(keys); } PUSHs(TARG); @@ -1587,7 +1587,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo return; } if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV - && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM) + && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM + && type != SVt_PVIO) || (type == SVt_IV && !SvROK(sv))) { if (SvIsUV(sv) #ifdef PERL_OLD_COPY_ON_WRITE @@ -218,7 +218,7 @@ Afp |OP* |die |NULLOK const char* pat|... s |OP* |vdie |NULLOK const char* pat|NULLOK va_list* args #endif : Used in util.c -p |OP* |die_where |NULLOK SV* msv +pr |void |die_where |NULLOK SV* msv Ap |void |dounwind |I32 cxix : FIXME pmb |bool |do_aexec |NULLOK SV* really|NN SV** mark|NN SV** sp @@ -355,7 +355,7 @@ Apd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash|NN const char* name|STRLEN len Apdmb |GV* |gv_fetchmethod |NN HV* stash|NN const char* name Apd |GV* |gv_fetchmethod_autoload|NN HV* stash|NN const char* name \ |I32 autoload -ApdM |GV* |gv_fetchmethod_flags|NN HV* stash|NN const char* name \ +ApM |GV* |gv_fetchmethod_flags|NN HV* stash|NN const char* name \ |U32 flags Ap |GV* |gv_fetchpv |NN const char *nambeg|I32 add|const svtype sv_type Ap |void |gv_fullname |NN SV* sv|NN const GV* gv @@ -365,6 +365,7 @@ Ap |void |gv_fullname4 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool pMox |GP * |newGP |NN GV *const gv Ap |void |gv_init |NN GV* gv|NULLOK HV* stash|NN const char* name|STRLEN len|int multi Ap |void |gv_name_set |NN GV* gv|NN const char *name|U32 len|U32 flags +Apd |void |gv_try_downgrade|NN GV* gv Apd |HV* |gv_stashpv |NN const char* name|I32 flags Apd |HV* |gv_stashpvn |NN const char* name|U32 namelen|I32 flags Apd |HV* |gv_stashsv |NN SV* sv|I32 flags @@ -420,7 +421,7 @@ Abmd |SV** |hv_store |NULLOK HV *hv|NULLOK const char *key \ |I32 klen|NULLOK SV *val|U32 hash Abmd |HE* |hv_store_ent |NULLOK HV *hv|NULLOK SV *key|NULLOK SV *val\ |U32 hash -AbmdM |SV** |hv_store_flags |NULLOK HV *hv|NULLOK const char *key \ +AbmM |SV** |hv_store_flags |NULLOK HV *hv|NULLOK const char *key \ |I32 klen|NULLOK SV *val|U32 hash|int flags Apd |void |hv_undef |NULLOK HV *hv AnpP |I32 |ibcmp |NN const char* a|NN const char* b|I32 len @@ -507,12 +508,26 @@ p |OP* |jmaybe |NN OP *o pP |I32 |keyword |NN const char *name|I32 len|bool all_keywords #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) s |OP* |opt_scalarhv |NN OP* rep_op +s |OP* |is_inplace_av |NN OP* o|NULLOK OP* oright #endif Ap |void |leave_scope |I32 base : Used in pp_ctl.c, and by Data::Alias EXp |void |lex_end : Used in various files p |void |lex_start |NULLOK SV* line|NULLOK PerlIO *rsfp|bool new_filter +: Public lexer API +AMpd |bool |lex_bufutf8 +AMpd |char* |lex_grow_linestr|STRLEN len +AMpd |void |lex_stuff_pvn |NN char* pv|STRLEN len|U32 flags +AMpd |void |lex_stuff_sv |NN SV* sv|U32 flags +AMpd |void |lex_unstuff |NN char* ptr +AMpd |void |lex_read_to |NN char* ptr +AMpd |void |lex_discard_to |NN char* ptr +AMpd |bool |lex_next_chunk |U32 flags +AMpd |I32 |lex_peek_unichar|U32 flags +AMpd |I32 |lex_read_unichar|U32 flags +AMpd |void |lex_read_space |U32 flags +: Used in various files Ap |void |op_null |NN OP* o : FIXME. Used by Data::Alias EXp |void |op_clear |NN OP* o @@ -743,9 +758,10 @@ p |void |package_version|NN OP* v : Used in op.c pd |PADOFFSET|pad_alloc |I32 optype|U32 tmptype : Used in toke.c and perly.y -p |PADOFFSET|allocmy |NN const char *const name +p |PADOFFSET|allocmy |NN const char *const name|const STRLEN len\ + |const U32 flags : Used in op.c and toke.c -pdR |PADOFFSET|pad_findmy |NN const char* name +AMpdR |PADOFFSET|pad_findmy |NN const char* name|STRLEN len|U32 flags Ap |PADOFFSET|find_rundefsvoffset | : Used in perly.y pR |OP* |oopsAV |NN OP* o @@ -753,7 +769,9 @@ pR |OP* |oopsAV |NN OP* o pR |OP* |oopsHV |NN OP* o : Defined in pad.c, used only in op.c pd |void |pad_leavemy +#ifdef DEBUGGING Apd |SV* |pad_sv |PADOFFSET po +#endif : Defined in pad.c, used only in op.c pd |void |pad_free |PADOFFSET po #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) @@ -1360,7 +1378,7 @@ s |HV* |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \ : #if defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) : Used in hv.c -paRxo |void* |get_arena |const size_t svtype|const U32 misc +paRxoM |void* |get_arena |const size_t arenasize |const svtype bodytype : #endif #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) @@ -1875,7 +1893,7 @@ Apd |void |sv_catpvn_flags|NN SV *const dstr|NN const char *sstr|const STRLEN le |const I32 flags Apd |void |sv_catsv_flags |NN SV *const dsv|NULLOK SV *const ssv|const I32 flags Apmd |STRLEN |sv_utf8_upgrade_flags|NN SV *const sv|const I32 flags -Apd |STRLEN |sv_utf8_upgrade_flags_grow|NN SV *const sv|const I32 flags|STRLEN extra +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 Apd |void |sv_copypv |NN SV *const dsv|NN SV *const ssv Ap |char* |my_atof2 |NN const char *s|NN NV* value @@ -1931,12 +1949,15 @@ pda |PADLIST*|pad_new |int flags : Only used in op.c pd |void |pad_undef |NN CV* cv : Only used in op.c -pd |PADOFFSET|pad_add_name |NN const char *name\ - |NULLOK HV* typestash|NULLOK HV* ourstash|bool clone|bool state +Mpd |PADOFFSET|pad_add_name |NN const char *name|const STRLEN len\ + |const U32 flags|NULLOK HV *typestash\ + |NULLOK HV *ourstash : Only used in op.c pd |PADOFFSET|pad_add_anon |NN SV* sv|OPCODE op_type -: Only used in op.c -pd |void |pad_check_dup |NN const char* name|bool is_our|NN const HV* ourstash +#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) +sd |void |pad_check_dup |NN SV *name|const U32 flags \ + |NULLOK const HV *ourstash +#endif #ifdef DEBUGGING : Only used PAD_SETSV() in op.c pd |void |pad_setsv |PADOFFSET po|NN SV* sv @@ -1959,6 +1980,8 @@ pR |HV* |pad_compname_type|const PADOFFSET po sd |PADOFFSET|pad_findlex |NN const char *name|NN const CV* cv|U32 seq|int warn \ |NULLOK SV** out_capture|NN SV** out_name_sv \ |NN int *out_flags +s |PADOFFSET|pad_add_name_sv|NN SV *namesv|const U32 flags \ + |NULLOK HV *typestash|NULLOK HV *ourstash # if defined(DEBUGGING) sd |void |cv_dump |NN const CV *cv|NN const char *title # endif @@ -1971,7 +1994,9 @@ p |void |free_tied_hv_pool pR |int |get_debug_opts |NN const char **s|bool givehelp #endif Ap |void |save_set_svflags|NN SV *sv|U32 mask|U32 val +#ifdef DEBUGGING Apod |void |hv_assert |NN HV *hv +#endif ApdR |SV* |hv_scalar |NN HV *hv ApoR |I32* |hv_riter_p |NN HV *hv @@ -2228,6 +2253,8 @@ ApoM |const char *|fetch_cop_label|NULLOK struct refcounted_he *const chain \ xpoM |struct refcounted_he *|store_cop_label \ |NULLOK struct refcounted_he *const chain|NN const char *label +xpo |int |keyword_plugin_standard|NN char* keyword_ptr|STRLEN keyword_len|NN OP** op_ptr + END_EXTERN_C /* * ex: set ts=8 sts=4 sw=4 noet: @@ -291,6 +291,7 @@ #define gv_fullname4 Perl_gv_fullname4 #define gv_init Perl_gv_init #define gv_name_set Perl_gv_name_set +#define gv_try_downgrade Perl_gv_try_downgrade #define gv_stashpv Perl_gv_stashpv #define gv_stashpvn Perl_gv_stashpvn #define gv_stashsv Perl_gv_stashsv @@ -397,6 +398,7 @@ #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define opt_scalarhv S_opt_scalarhv +#define is_inplace_av S_is_inplace_av #endif #endif #define leave_scope Perl_leave_scope @@ -406,6 +408,17 @@ #ifdef PERL_CORE #define lex_start Perl_lex_start #endif +#define lex_bufutf8 Perl_lex_bufutf8 +#define lex_grow_linestr Perl_lex_grow_linestr +#define lex_stuff_pvn Perl_lex_stuff_pvn +#define lex_stuff_sv Perl_lex_stuff_sv +#define lex_unstuff Perl_lex_unstuff +#define lex_read_to Perl_lex_read_to +#define lex_discard_to Perl_lex_discard_to +#define lex_next_chunk Perl_lex_next_chunk +#define lex_peek_unichar Perl_lex_peek_unichar +#define lex_read_unichar Perl_lex_read_unichar +#define lex_read_space Perl_lex_read_space #define op_null Perl_op_null #if defined(PERL_CORE) || defined(PERL_EXT) #define op_clear Perl_op_clear @@ -638,15 +651,17 @@ #define package_version Perl_package_version #define pad_alloc Perl_pad_alloc #define allocmy Perl_allocmy -#define pad_findmy Perl_pad_findmy #endif +#define pad_findmy Perl_pad_findmy #define find_rundefsvoffset Perl_find_rundefsvoffset #ifdef PERL_CORE #define oopsAV Perl_oopsAV #define oopsHV Perl_oopsHV #define pad_leavemy Perl_pad_leavemy #endif +#ifdef DEBUGGING #define pad_sv Perl_pad_sv +#endif #ifdef PERL_CORE #define pad_free Perl_pad_free #endif @@ -1712,7 +1727,11 @@ #define pad_undef Perl_pad_undef #define pad_add_name Perl_pad_add_name #define pad_add_anon Perl_pad_add_anon -#define pad_check_dup Perl_pad_check_dup +#endif +#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define pad_check_dup S_pad_check_dup +#endif #endif #ifdef DEBUGGING #ifdef PERL_CORE @@ -1732,6 +1751,7 @@ #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pad_findlex S_pad_findlex +#define pad_add_name_sv S_pad_add_name_sv #endif # if defined(DEBUGGING) #ifdef PERL_CORE @@ -1749,6 +1769,8 @@ #endif #endif #define save_set_svflags Perl_save_set_svflags +#ifdef DEBUGGING +#endif #define hv_scalar Perl_hv_scalar #define hv_name_set Perl_hv_name_set #if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) @@ -2654,6 +2676,7 @@ #endif #define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e) #define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d) +#define gv_try_downgrade(a) Perl_gv_try_downgrade(aTHX_ a) #define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b) #define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c) #define gv_stashsv(a,b) Perl_gv_stashsv(aTHX_ a,b) @@ -2768,6 +2791,7 @@ #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define opt_scalarhv(a) S_opt_scalarhv(aTHX_ a) +#define is_inplace_av(a,b) S_is_inplace_av(aTHX_ a,b) #endif #endif #define leave_scope(a) Perl_leave_scope(aTHX_ a) @@ -2777,6 +2801,17 @@ #ifdef PERL_CORE #define lex_start(a,b,c) Perl_lex_start(aTHX_ a,b,c) #endif +#define lex_bufutf8() Perl_lex_bufutf8(aTHX) +#define lex_grow_linestr(a) Perl_lex_grow_linestr(aTHX_ a) +#define lex_stuff_pvn(a,b,c) Perl_lex_stuff_pvn(aTHX_ a,b,c) +#define lex_stuff_sv(a,b) Perl_lex_stuff_sv(aTHX_ a,b) +#define lex_unstuff(a) Perl_lex_unstuff(aTHX_ a) +#define lex_read_to(a) Perl_lex_read_to(aTHX_ a) +#define lex_discard_to(a) Perl_lex_discard_to(aTHX_ a) +#define lex_next_chunk(a) Perl_lex_next_chunk(aTHX_ a) +#define lex_peek_unichar(a) Perl_lex_peek_unichar(aTHX_ a) +#define lex_read_unichar(a) Perl_lex_read_unichar(aTHX_ a) +#define lex_read_space(a) Perl_lex_read_space(aTHX_ a) #define op_null(a) Perl_op_null(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define op_clear(a) Perl_op_clear(aTHX_ a) @@ -3005,16 +3040,18 @@ #ifdef PERL_CORE #define package_version(a) Perl_package_version(aTHX_ a) #define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) -#define allocmy(a) Perl_allocmy(aTHX_ a) -#define pad_findmy(a) Perl_pad_findmy(aTHX_ a) +#define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c) #endif +#define pad_findmy(a,b,c) Perl_pad_findmy(aTHX_ a,b,c) #define find_rundefsvoffset() Perl_find_rundefsvoffset(aTHX) #ifdef PERL_CORE #define oopsAV(a) Perl_oopsAV(aTHX_ a) #define oopsHV(a) Perl_oopsHV(aTHX_ a) #define pad_leavemy() Perl_pad_leavemy(aTHX) #endif +#ifdef DEBUGGING #define pad_sv(a) Perl_pad_sv(aTHX_ a) +#endif #ifdef PERL_CORE #define pad_free(a) Perl_pad_free(aTHX_ a) #endif @@ -4087,7 +4124,11 @@ #define pad_undef(a) Perl_pad_undef(aTHX_ a) #define pad_add_name(a,b,c,d,e) Perl_pad_add_name(aTHX_ a,b,c,d,e) #define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b) -#define pad_check_dup(a,b,c) Perl_pad_check_dup(aTHX_ a,b,c) +#endif +#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define pad_check_dup(a,b,c) S_pad_check_dup(aTHX_ a,b,c) +#endif #endif #ifdef DEBUGGING #ifdef PERL_CORE @@ -4107,6 +4148,7 @@ #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define pad_findlex(a,b,c,d,e,f,g) S_pad_findlex(aTHX_ a,b,c,d,e,f,g) +#define pad_add_name_sv(a,b,c,d) S_pad_add_name_sv(aTHX_ a,b,c,d) #endif # if defined(DEBUGGING) #ifdef PERL_CORE @@ -4124,6 +4166,8 @@ #endif #endif #define save_set_svflags(a,b,c) Perl_save_set_svflags(aTHX_ a,b,c) +#ifdef DEBUGGING +#endif #define hv_scalar(a) Perl_hv_scalar(aTHX_ a) #define hv_name_set(a,b,c,d) Perl_hv_name_set(aTHX_ a,b,c,d) #ifdef PERL_CORE @@ -4382,6 +4426,8 @@ #endif #ifdef PERL_CORE #endif +#ifdef PERL_CORE +#endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_chdir(a) Perl_ck_chdir(aTHX_ a) diff --git a/embedvar.h b/embedvar.h index 9d6d4c314b..e805a79822 100644 --- a/embedvar.h +++ b/embedvar.h @@ -265,6 +265,7 @@ #define PL_scopestack (vTHX->Iscopestack) #define PL_scopestack_ix (vTHX->Iscopestack_ix) #define PL_scopestack_max (vTHX->Iscopestack_max) +#define PL_scopestack_name (vTHX->Iscopestack_name) #define PL_screamfirst (vTHX->Iscreamfirst) #define PL_screamnext (vTHX->Iscreamnext) #define PL_secondgv (vTHX->Isecondgv) @@ -581,6 +582,7 @@ #define PL_Iscopestack PL_scopestack #define PL_Iscopestack_ix PL_scopestack_ix #define PL_Iscopestack_max PL_scopestack_max +#define PL_Iscopestack_name PL_scopestack_name #define PL_Iscreamfirst PL_screamfirst #define PL_Iscreamnext PL_screamnext #define PL_Isecondgv PL_secondgv @@ -701,6 +703,8 @@ #define PL_Ginterp_size (my_vars->Ginterp_size) #define PL_interp_size_5_10_0 (my_vars->Ginterp_size_5_10_0) #define PL_Ginterp_size_5_10_0 (my_vars->Ginterp_size_5_10_0) +#define PL_keyword_plugin (my_vars->Gkeyword_plugin) +#define PL_Gkeyword_plugin (my_vars->Gkeyword_plugin) #define PL_malloc_mutex (my_vars->Gmalloc_mutex) #define PL_Gmalloc_mutex (my_vars->Gmalloc_mutex) #define PL_mmap_page_size (my_vars->Gmmap_page_size) @@ -780,6 +784,7 @@ #define PL_Ghints_mutex PL_hints_mutex #define PL_Ginterp_size PL_interp_size #define PL_Ginterp_size_5_10_0 PL_interp_size_5_10_0 +#define PL_Gkeyword_plugin PL_keyword_plugin #define PL_Gmalloc_mutex PL_malloc_mutex #define PL_Gmmap_page_size PL_mmap_page_size #define PL_Gmy_ctx_mutex PL_my_ctx_mutex diff --git a/epoc/config.sh b/epoc/config.sh index 8623a8519f..8fd50b05df 100644 --- a/epoc/config.sh +++ b/epoc/config.sh @@ -33,8 +33,8 @@ apirevision='' apisubversion='' apiversion='' ar='arm-epoc-pe-ar' -archlib='/usr/lib/perl/5.11.1/epoc' -archlibexp='/usr/lib/perl/5.11.1/epoc' +archlib='/usr/lib/perl/5.11.2/epoc' +archlibexp='/usr/lib/perl/5.11.2/epoc' archname64='' archname='epoc' archobjs='epoc.o epocish.o epoc_stubs.o' @@ -58,6 +58,7 @@ ccsymbols='' cf_by='olaf' cf_email='o.flebbe@gmx.de' cf_time='Dec 2001' +charbits='8' chgrp='' chmod='' chown='' @@ -761,8 +762,8 @@ pmake='' pr='' prefix='' prefixexp='' -privlib='/usr/lib/perl/5.11.1' -privlibexp='/usr/lib/perl/5.11.1' +privlib='/usr/lib/perl/5.11.2' +privlibexp='/usr/lib/perl/5.11.2' procselfexe='' prototype='define' ptrsize='4' @@ -821,11 +822,11 @@ sig_num='0' sig_num_init='0, 0' sig_size='1' signal_t='void' -sitearch='/usr/lib/perl/site_perl/5.11.1/epoc' -sitearchexp='/usr/lib/perl/site_perl/5.11.1/epoc' -sitelib='/usr/lib/perl/site_perl/5.11.1/' +sitearch='/usr/lib/perl/site_perl/5.11.2/epoc' +sitearchexp='/usr/lib/perl/site_perl/5.11.2/epoc' +sitelib='/usr/lib/perl/site_perl/5.11.2/' sitelib_stem='/usr/lib/perl/site_perl' -sitelibexp='/usr/lib/perl/site_perl/5.11.1/' +sitelibexp='/usr/lib/perl/site_perl/5.11.2/' siteprefix='' siteprefixexp='' sizesize='4' @@ -908,7 +909,7 @@ vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.11.1' +version='5.11.2' versiononly='undef' vi='' voidflags='15' @@ -932,7 +933,7 @@ config_arg10='' config_arg11='' PERL_REVISION=5 PERL_VERSION=11 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=11 PERL_API_SUBVERSION=0 @@ -1041,7 +1042,7 @@ vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.11.1' +version='5.11.2' vi='' voidflags='15' xlibpth='' @@ -1064,7 +1065,7 @@ config_arg10='' config_arg11='' PERL_REVISION=5 PERL_VERSION=11 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=11 PERL_API_SUBVERSION=0 @@ -1165,16 +1166,16 @@ d_SCNfldbl='undef' d_perl_otherlibdirs='undef' nvsize='16' issymlink='' -installarchlib='/home/of/PERL/perl/lib/5.11.1/epoc' +installarchlib='/home/of/PERL/perl/lib/5.11.2/epoc' installbin='/home/of/PERL/System/Programs/' installman1dir='/home/of/PERL/man1' installman3dir='/home/of/PERL/man3' installprefix='' installprefixexp='' -installprivlib='/home/of/PERL/perl/lib/5.11.1/' +installprivlib='/home/of/PERL/perl/lib/5.11.2/' installscript='/home/of/PERL/bin/' -installsitearch='/home/of/PERL/site/lib/site_perl/5.11.1/epoc' -installsitelib='/home/of/PERL/perl/lib/site_perl/5.11.1' +installsitearch='/home/of/PERL/site/lib/site_perl/5.11.2/epoc' +installsitelib='/home/of/PERL/perl/lib/site_perl/5.11.2' installstyle='' installusrbinperl='undef' installvendorlib='' diff --git a/epoc/createpkg.pl b/epoc/createpkg.pl index 6dca6585f7..7e872062ec 100644 --- a/epoc/createpkg.pl +++ b/epoc/createpkg.pl @@ -3,7 +3,7 @@ use File::Find; use Cwd; -$VERSION="5.11.1"; +$VERSION="5.11.2"; $EPOC_VERSION=1; diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 671212d203..2699605894 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -634,6 +634,7 @@ $priv{"list"}{64} = "GUESSED"; $priv{"delete"}{64} = "SLICE"; $priv{"exists"}{64} = "SUB"; @{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE"); +$priv{"reverse"}{8} = "INPLACE"; $priv{"threadsv"}{64} = "SVREFd"; @{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR") for ("open", "backtick"); diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index d90011394d..8e51b880db 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -161,10 +161,10 @@ my $testpkgs = { OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC - OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT - OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE - PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP - PMf_MULTILINE PMf_ONCE PMf_SINGLELINE + OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY + OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH + PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL + PMf_KEEP PMf_MULTILINE PMf_ONCE PMf_SINGLELINE POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE'), diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 4a4d27493d..aeb36d074d 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -616,7 +616,7 @@ do_test(25, SV = PVIO\\($ADDR\\) at $ADDR REFCNT = 3 FLAGS = \\(OBJECT\\) - IV = 0 + IV = 0 # $] < 5.011 NV = 0 # $] < 5.011 STASH = $ADDR\s+"IO::Handle" IFP = $ADDR diff --git a/ext/I18N-Langinfo/Langinfo.pm b/ext/I18N-Langinfo/Langinfo.pm index cebff73fb2..38d8f10e6e 100644 --- a/ext/I18N-Langinfo/Langinfo.pm +++ b/ext/I18N-Langinfo/Langinfo.pm @@ -73,7 +73,7 @@ our @EXPORT_OK = qw( YESSTR ); -our $VERSION = '0.02'; +our $VERSION = '0.03'; sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() @@ -193,7 +193,7 @@ you can wrap the import in an eval like this: =head2 EXPORT -Nothing is exported by default. +By default only the C<langinfo()> function is exported. =head1 SEE ALSO diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index eccbb3170d..7bdd6339b7 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -216,6 +216,129 @@ char *tzname[] = { "" , "" }; #endif /* WIN32 || NETWARE */ #endif /* __VMS */ +#ifdef WIN32 + /* Perl on Windows assigns WSAGetLastError() return values to errno + * (in win32/win32sck.c). Therefore we need to map these values + * back to standard symbolic names, as long as the same name isn't + * already defined by errno.h itself. The Errno.pm module does + * a similar mapping. + */ +# ifndef EWOULDBLOCK +# define EWOULDBLOCK WSAEWOULDBLOCK +# endif +# ifndef EINPROGRESS +# define EINPROGRESS WSAEINPROGRESS +# endif +# ifndef EALREADY +# define EALREADY WSAEALREADY +# endif +# ifndef ENOTSOCK +# define ENOTSOCK WSAENOTSOCK +# endif +# ifndef EDESTADDRREQ +# define EDESTADDRREQ WSAEDESTADDRREQ +# endif +# ifndef EMSGSIZE +# define EMSGSIZE WSAEMSGSIZE +# endif +# ifndef EPROTOTYPE +# define EPROTOTYPE WSAEPROTOTYPE +# endif +# ifndef ENOPROTOOPT +# define ENOPROTOOPT WSAENOPROTOOPT +# endif +# ifndef EPROTONOSUPPORT +# define EPROTONOSUPPORT WSAEPROTONOSUPPORT +# endif +# ifndef ESOCKTNOSUPPORT +# define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT +# endif +# ifndef EOPNOTSUPP +# define EOPNOTSUPP WSAEOPNOTSUPP +# endif +# ifndef EPFNOSUPPORT +# define EPFNOSUPPORT WSAEPFNOSUPPORT +# endif +# ifndef EAFNOSUPPORT +# define EAFNOSUPPORT WSAEAFNOSUPPORT +# endif +# ifndef EADDRINUSE +# define EADDRINUSE WSAEADDRINUSE +# endif +# ifndef EADDRNOTAVAIL +# define EADDRNOTAVAIL WSAEADDRNOTAVAIL +# endif +# ifndef ENETDOWN +# define ENETDOWN WSAENETDOWN +# endif +# ifndef ENETUNREACH +# define ENETUNREACH WSAENETUNREACH +# endif +# ifndef ENETRESET +# define ENETRESET WSAENETRESET +# endif +# ifndef ECONNABORTED +# define ECONNABORTED WSAECONNABORTED +# endif +# ifndef ECONNRESET +# define ECONNRESET WSAECONNRESET +# endif +# ifndef ENOBUFS +# define ENOBUFS WSAENOBUFS +# endif +# ifndef EISCONN +# define EISCONN WSAEISCONN +# endif +# ifndef ENOTCONN +# define ENOTCONN WSAENOTCONN +# endif +# ifndef ESHUTDOWN +# define ESHUTDOWN WSAESHUTDOWN +# endif +# ifndef ETOOMANYREFS +# define ETOOMANYREFS WSAETOOMANYREFS +# endif +# ifndef ETIMEDOUT +# define ETIMEDOUT WSAETIMEDOUT +# endif +# ifndef ECONNREFUSED +# define ECONNREFUSED WSAECONNREFUSED +# endif +# ifndef ELOOP +# define ELOOP WSAELOOP +# endif +# ifndef ENAMETOOLONG +# define ENAMETOOLONG WSAENAMETOOLONG +# endif +# ifndef EHOSTDOWN +# define EHOSTDOWN WSAEHOSTDOWN +# endif +# ifndef EHOSTUNREACH +# define EHOSTUNREACH WSAEHOSTUNREACH +# endif +# ifndef ENOTEMPTY +# define ENOTEMPTY WSAENOTEMPTY +# endif +# ifndef EPROCLIM +# define EPROCLIM WSAEPROCLIM +# endif +# ifndef EUSERS +# define EUSERS WSAEUSERS +# endif +# ifndef EDQUOT +# define EDQUOT WSAEDQUOT +# endif +# ifndef ESTALE +# define ESTALE WSAESTALE +# endif +# ifndef EREMOTE +# define EREMOTE WSAEREMOTE +# endif +# ifndef EDISCON +# define EDISCON WSAEDISCON +# endif +#endif + typedef int SysRet; typedef long SysRetLong; typedef sigset_t* POSIX__SigSet; @@ -764,8 +887,8 @@ WEXITSTATUS(status) POSIX::WSTOPSIG = 4 POSIX::WTERMSIG = 5 CODE: -#if !(defined(WEXITSTATUS) || defined(WIFEXITED) || defined(WIFSIGNALED) \ - || defined(WIFSTOPPED) || defined(WSTOPSIG) || defined (WTERMSIG)) +#if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \ + || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG) RETVAL = 0; /* Silence compilers that notice this, but don't realise that not_here() can't return. */ #endif @@ -1298,8 +1421,10 @@ sigaction(sig, optaction, oldaction = 0) sv_setpvs(*svp, "DEFAULT"); } RETVAL = sigaction(sig, (struct sigaction *)0, & oact); - if(RETVAL == -1) + if(RETVAL == -1) { + LEAVE; XSRETURN_UNDEF; + } /* Get back the mask. */ svp = hv_fetchs(oldaction, "MASK", TRUE); if (sv_isa(*svp, "POSIX::SigSet")) { @@ -1379,8 +1504,10 @@ sigaction(sig, optaction, oldaction = 0) * essentially meaningless anyway. */ RETVAL = sigaction(sig, & act, (struct sigaction *)0); - if(RETVAL == -1) + if(RETVAL == -1) { + LEAVE; XSRETURN_UNDEF; + } } LEAVE; diff --git a/ext/POSIX/t/time.t b/ext/POSIX/t/time.t index 01ce87fa8e..dad1f6a310 100644 --- a/ext/POSIX/t/time.t +++ b/ext/POSIX/t/time.t @@ -28,6 +28,14 @@ SKIP: { } } +if ($^O eq "hpux" && $Config{osvers} >= 11.3) { + # HP does not support UTC0UTC and/or GMT0GMT, as they state that this is + # legal syntax but as it has no DST rule, it cannot be used. That is the + # conclusion of bug + # QXCR1000896916: Some timezone valuesfailing on 11.31 that work on 11.23 + $ENV{TZ} = "UTC"; +} + # asctime and ctime...Let's stay below INT_MAX for 32-bits and # positive for some picky systems. diff --git a/ext/XS-APItest-KeywordRPN/KeywordRPN.pm b/ext/XS-APItest-KeywordRPN/KeywordRPN.pm new file mode 100644 index 0000000000..2114c611d3 --- /dev/null +++ b/ext/XS-APItest-KeywordRPN/KeywordRPN.pm @@ -0,0 +1,143 @@ +=head1 NAME + +XS::APItest::KeywordRPN - write arithmetic expressions in RPN + +=head1 SYNOPSIS + + use XS::APItest::KeywordRPN qw(rpn calcrpn); + + $triangle = rpn($n $n 1 + * 2 /); + + calcrpn $triangle { $n $n 1 + * 2 / } + +=head1 DESCRIPTION + +This module supplies plugged-in keywords, using the new mechanism in Perl +5.11.2, that allow arithmetic to be expressed in reverse Polish notation, +in an otherwise Perl program. This module has serious limitations and +is not intended for real use: its purpose is only to test the keyword +plugin mechanism. For that purpose it is part of the Perl core source +distribution, and is not meant to be installed. + +=head2 RPN expression syntax + +Tokens of an RPN expression may be separated by whitespace, but such +separation is usually not required. It is required only where unseparated +tokens would look like a longer token. For example, C<12 34 +> can be +written as C<12 34+>, but not as C<1234 +>. + +An RPN expression may be any of: + +=over + +=item C<1234> + +A sequence of digits is an unsigned decimal literal number. + +=item C<$foo> + +An alphanumeric name preceded by dollar sign refers to a Perl scalar +variable. Only variables declared with C<my> or C<state> are supported. +If the variable's value is not a native integer, it will be converted +to an integer, by Perl's usual mechanisms, at the time it is evaluated. + +=item I<A> I<B> C<+> + +Sum of I<A> and I<B>. + +=item I<A> I<B> C<-> + +Difference of I<A> and I<B>, the result of subtracting I<B> from I<A>. + +=item I<A> I<B> C<*> + +Product of I<A> and I<B>. + +=item I<A> I<B> C</> + +Quotient when I<A> is divided by I<B>, rounded towards zero. +Division by zero generates an exception. + +=item I<A> I<B> C<%> + +Remainder when I<A> is divided by I<B> with the quotient rounded towards zero. +Division by zero generates an exception. + +=back + +Because the arithmetic operators all have fixed arity and are postfixed, +there is no need for operator precedence, nor for a grouping operator +to override precedence. This is half of the point of RPN. + +An RPN expression can also be interpreted in another way, as a sequence +of operations on a stack, one operation per token. A literal or variable +token pushes a value onto the stack. A binary operator pulls two items +off the stack, performs a calculation with them, and pushes the result +back onto the stack. The stack starts out empty, and at the end of the +expression there must be exactly one value left on the stack. + +=cut + +package XS::APItest::KeywordRPN; + +{ use 5.011001; } +use warnings; +use strict; + +our $VERSION = "0.003"; + +require XSLoader; +XSLoader::load(__PACKAGE__, $VERSION); + +=head1 OPERATORS + +These are the operators being added to the Perl language. + +=over + +=item rpn(EXPRESSION) + +This construct is a Perl expression. I<EXPRESSION> must be an RPN +arithmetic expression, as described above. The RPN expression is +evaluated, and its value is returned as the value of the Perl expression. + +=item calcrpn VARIABLE { EXPRESSION } + +This construct is a complete Perl statement. (No semicolon should +follow the closing brace.) I<VARIABLE> must be a Perl scalar C<my> +variable, and I<EXPRESSION> must be an RPN arithmetic expression as +described above. The RPN expression is evaluated, and its value is +assigned to the variable. + +=back + +=head1 BUGS + +This module only performs arithmetic on native integers, and only a +small subset of the arithmetic operations that Perl offers. This is +due to it being intended only for demonstration and test purposes. + +The RPN parser is liable to leak memory when a parse error occurs. +It doesn't leak on success, however. + +=head1 SEE ALSO + +L<Devel::Declare>, +L<perlapi/PL_keyword_plugin> + +=head1 AUTHOR + +Andrew Main (Zefram) <zefram@fysh.org> + +=head1 COPYRIGHT + +Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org> + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1; diff --git a/ext/XS-APItest-KeywordRPN/KeywordRPN.xs b/ext/XS-APItest-KeywordRPN/KeywordRPN.xs new file mode 100644 index 0000000000..e205eeaf0f --- /dev/null +++ b/ext/XS-APItest-KeywordRPN/KeywordRPN.xs @@ -0,0 +1,249 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV) +#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP) +#define sv_is_string(sv) \ + (!sv_is_glob(sv) && !sv_is_regexp(sv) && \ + (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK))) + +static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv; +static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); + +/* low-level parser helpers */ + +#define PL_bufptr (PL_parser->bufptr) +#define PL_bufend (PL_parser->bufend) + +/* RPN parser */ + +static OP *THX_parse_var(pTHX) +{ + char *s = PL_bufptr; + char *start = s; + PADOFFSET varpos; + OP *padop; + if(*s != '$') croak("RPN syntax error"); + while(1) { + char c = *++s; + if(!isALNUM(c)) break; + } + if(s-start < 2) croak("RPN syntax error"); + lex_read_to(s); + { + /* because pad_findmy() doesn't really use length yet */ + SV *namesv = sv_2mortal(newSVpvn(start, s-start)); + varpos = pad_findmy(SvPVX(namesv), s-start, 0); + } + if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos)) + croak("RPN only supports \"my\" variables"); + padop = newOP(OP_PADSV, 0); + padop->op_targ = varpos; + return padop; +} +#define parse_var() THX_parse_var(aTHX) + +#define push_rpn_item(o) \ + (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop) +#define pop_rpn_item() \ + (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \ + (tmpop = stack, stack = stack->op_sibling, \ + tmpop->op_sibling = NULL, tmpop)) + +static OP *THX_parse_rpn_expr(pTHX) +{ + OP *stack = NULL, *tmpop; + while(1) { + I32 c; + lex_read_space(0); + c = lex_peek_unichar(0); + switch(c) { + case /*(*/')': case /*{*/'}': { + OP *result = pop_rpn_item(); + if(stack) + croak("RPN expression must return " + "a single value"); + return result; + } break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': { + UV val = 0; + do { + lex_read_unichar(0); + val = 10*val + (c - '0'); + c = lex_peek_unichar(0); + } while(c >= '0' && c <= '9'); + push_rpn_item(newSVOP(OP_CONST, 0, + newSVuv(val))); + } break; + case '$': { + push_rpn_item(parse_var()); + } break; + case '+': { + OP *b = pop_rpn_item(); + OP *a = pop_rpn_item(); + lex_read_unichar(0); + push_rpn_item(newBINOP(OP_I_ADD, 0, a, b)); + } break; + case '-': { + OP *b = pop_rpn_item(); + OP *a = pop_rpn_item(); + lex_read_unichar(0); + push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b)); + } break; + case '*': { + OP *b = pop_rpn_item(); + OP *a = pop_rpn_item(); + lex_read_unichar(0); + push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b)); + } break; + case '/': { + OP *b = pop_rpn_item(); + OP *a = pop_rpn_item(); + lex_read_unichar(0); + push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b)); + } break; + case '%': { + OP *b = pop_rpn_item(); + OP *a = pop_rpn_item(); + lex_read_unichar(0); + push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b)); + } break; + default: { + croak("RPN syntax error"); + } break; + } + } +} +#define parse_rpn_expr() THX_parse_rpn_expr(aTHX) + +static OP *THX_parse_keyword_rpn(pTHX) +{ + OP *op; + lex_read_space(0); + if(lex_peek_unichar(0) != '('/*)*/) + croak("RPN expression must be parenthesised"); + lex_read_unichar(0); + op = parse_rpn_expr(); + if(lex_peek_unichar(0) != /*(*/')') + croak("RPN expression must be parenthesised"); + lex_read_unichar(0); + return op; +} +#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX) + +static OP *THX_parse_keyword_calcrpn(pTHX) +{ + OP *varop, *exprop; + lex_read_space(0); + varop = parse_var(); + lex_read_space(0); + if(lex_peek_unichar(0) != '{'/*}*/) + croak("RPN expression must be braced"); + lex_read_unichar(0); + exprop = parse_rpn_expr(); + if(lex_peek_unichar(0) != /*{*/'}') + croak("RPN expression must be braced"); + lex_read_unichar(0); + return newASSIGNOP(OPf_STACKED, varop, 0, exprop); +} +#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX) + +/* plugin glue */ + +static int THX_keyword_active(pTHX_ SV *hintkey_sv) +{ + HE *he; + if(!GvHV(PL_hintgv)) return 0; + he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0, + SvSHARED_HASH(hintkey_sv)); + return he && SvTRUE(HeVAL(he)); +} +#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv) + +static void THX_keyword_enable(pTHX_ SV *hintkey_sv) +{ + SV *val_sv = newSViv(1); + HE *he; + PL_hints |= HINT_LOCALIZE_HH; + gv_HVadd(PL_hintgv); + he = hv_store_ent(GvHV(PL_hintgv), + hintkey_sv, val_sv, SvSHARED_HASH(hintkey_sv)); + if(he) { + SV *val = HeVAL(he); + SvSETMAGIC(val); + } else { + SvREFCNT_dec(val_sv); + } +} +#define keyword_enable(hintkey_sv) THX_keyword_enable(aTHX_ hintkey_sv) + +static void THX_keyword_disable(pTHX_ SV *hintkey_sv) +{ + if(GvHV(PL_hintgv)) { + PL_hints |= HINT_LOCALIZE_HH; + hv_delete_ent(GvHV(PL_hintgv), + hintkey_sv, G_DISCARD, SvSHARED_HASH(hintkey_sv)); + } +} +#define keyword_disable(hintkey_sv) THX_keyword_disable(aTHX_ hintkey_sv) + +static int my_keyword_plugin(pTHX_ + char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) +{ + if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) && + keyword_active(hintkey_rpn_sv)) { + *op_ptr = parse_keyword_rpn(); + return KEYWORD_PLUGIN_EXPR; + } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) && + keyword_active(hintkey_calcrpn_sv)) { + *op_ptr = parse_keyword_calcrpn(); + return KEYWORD_PLUGIN_STMT; + } else { + return next_keyword_plugin(aTHX_ + keyword_ptr, keyword_len, op_ptr); + } +} + +MODULE = XS::APItest::KeywordRPN PACKAGE = XS::APItest::KeywordRPN + +BOOT: + hintkey_rpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/rpn"); + hintkey_calcrpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/calcrpn"); + next_keyword_plugin = PL_keyword_plugin; + PL_keyword_plugin = my_keyword_plugin; + +void +import(SV *classname, ...) +PREINIT: + int i; +PPCODE: + for(i = 1; i != items; i++) { + SV *item = ST(i); + if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) { + keyword_enable(hintkey_rpn_sv); + } else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) { + keyword_enable(hintkey_calcrpn_sv); + } else { + croak("\"%s\" is not exported by the %s module", + SvPV_nolen(item), SvPV_nolen(ST(0))); + } + } + +void +unimport(SV *classname, ...) +PREINIT: + int i; +PPCODE: + for(i = 1; i != items; i++) { + SV *item = ST(i); + if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) { + keyword_disable(hintkey_rpn_sv); + } else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) { + keyword_disable(hintkey_calcrpn_sv); + } else { + croak("\"%s\" is not exported by the %s module", + SvPV_nolen(item), SvPV_nolen(ST(0))); + } + } diff --git a/ext/XS-APItest-KeywordRPN/Makefile.PL b/ext/XS-APItest-KeywordRPN/Makefile.PL new file mode 100644 index 0000000000..ae2c72a40c --- /dev/null +++ b/ext/XS-APItest-KeywordRPN/Makefile.PL @@ -0,0 +1,17 @@ +{ use 5.006; } +use warnings; +use strict; + +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => "XS::APItest::KeywordRPN", + VERSION_FROM => "KeywordRPN.pm", + PREREQ_PM => {}, + ABSTRACT_FROM => "KeywordRPN.pm", + AUTHOR => "Andrew Main (Zefram) <zefram\@fysh.org>", +); + +sub MY::install { "install ::\n" } + +1; diff --git a/ext/XS-APItest-KeywordRPN/README b/ext/XS-APItest-KeywordRPN/README new file mode 100644 index 0000000000..4caa629af1 --- /dev/null +++ b/ext/XS-APItest-KeywordRPN/README @@ -0,0 +1,25 @@ +NAME + +XS::APItest::KeywordRPN - write arithmetic expressions in RPN + +DESCRIPTION + +This module supplies plugged-in keywords, using the new mechanism in Perl +5.11.2, that allow arithmetic to be expressed in reverse Polish notation, +in an otherwise Perl program. This module has serious limitations and +is not intended for real use: its purpose is only to test the keyword +plugin mechanism. For that purpose it is part of the Perl core source +distribution, and is not meant to be installed. + +AUTHOR + +Andrew Main (Zefram) <zefram@fysh.org> + +COPYRIGHT + +Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org> + +LICENSE + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. diff --git a/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t b/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t new file mode 100644 index 0000000000..85f4b603a3 --- /dev/null +++ b/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t @@ -0,0 +1,76 @@ +use warnings; +use strict; + +use Test::More tests => 13; + +BEGIN { $^H |= 0x20000; } +no warnings; + +my($triangle, $num); +$num = 5; + +$triangle = undef; +eval q{ + use XS::APItest::KeywordRPN (); + $triangle = rpn($num $num 1 + * 2 /); +}; +isnt $@, ""; + +$triangle = undef; +eval q{ + use XS::APItest::KeywordRPN qw(rpn); + $triangle = rpn($num $num 1 + * 2 /); +}; +is $@, ""; +is $triangle, 15; + +$triangle = undef; +eval q{ + use XS::APItest::KeywordRPN qw(rpn); + $triangle = join(":", "x", rpn($num $num 1 + * 2 /), "y"); +}; +is $@, ""; +is $triangle, "x:15:y"; + +$triangle = undef; +eval q{ + use XS::APItest::KeywordRPN qw(rpn); + $triangle = 1 + rpn($num $num 1 + * 2 /) * 10; +}; +is $@, ""; +is $triangle, 151; + +$triangle = undef; +eval q{ + use XS::APItest::KeywordRPN qw(rpn); + $triangle = rpn($num $num 1 + * 2 /); + $triangle++; +}; +is $@, ""; +is $triangle, 16; + +$triangle = undef; +eval q{ + use XS::APItest::KeywordRPN qw(rpn); + $triangle = rpn($num $num 1 + * 2 /) + $triangle++; +}; +isnt $@, ""; + +$triangle = undef; +eval q{ + use XS::APItest::KeywordRPN qw(calcrpn); + calcrpn $triangle { $num $num 1 + * 2 / } + $triangle++; +}; +is $@, ""; +is $triangle, 16; + +$triangle = undef; +eval q{ + use XS::APItest::KeywordRPN qw(calcrpn); + 123 + calcrpn $triangle { $num $num 1 + * 2 / } ; +}; +isnt $@, ""; + +1; diff --git a/ext/XS-APItest-KeywordRPN/t/multiline.t b/ext/XS-APItest-KeywordRPN/t/multiline.t new file mode 100644 index 0000000000..b5c9c83063 --- /dev/null +++ b/ext/XS-APItest-KeywordRPN/t/multiline.t @@ -0,0 +1,27 @@ +use warnings; +use strict; + +use Test::More tests => 4; + +my($t, $n); +$n = 5; + +use XS::APItest::KeywordRPN qw(rpn); +$t = rpn($n + $n 1 + + * #wibble +#wobble +2 + / +); +is $t, 15; +is __LINE__, 18; + +$t = 0; +$t = rpn($n $n 1 + * +#line 100 + 2 /); +is $t, 15; +is __LINE__, 102; + +1; diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index f80f3ea13e..11766f47ac 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -23,7 +23,7 @@ our @EXPORT = qw( print_double print_int print_long my_cxt_getint my_cxt_getsv my_cxt_setint my_cxt_setsv sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore rmagical_cast rmagical_flags - DPeek utf16_to_utf8 utf16_to_utf8_reversed pmflag + DPeek utf16_to_utf8 utf16_to_utf8_reversed pmflag my_exit ); our $VERSION = '0.17'; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index e8c36d7961..ede69949a1 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -931,3 +931,8 @@ pmflag (flag, before = 0) RETVAL = before; OUTPUT: RETVAL + +void +my_exit(int exitcode) + PPCODE: + my_exit(exitcode); diff --git a/ext/XS-APItest/t/my_exit.t b/ext/XS-APItest/t/my_exit.t new file mode 100644 index 0000000000..6f7cd8f5a8 --- /dev/null +++ b/ext/XS-APItest/t/my_exit.t @@ -0,0 +1,39 @@ +#!perl + +use strict; +use warnings; + +require "test.pl"; + +plan(4); + +use XS::APItest; + +my ($prog, $expect) = (<<'PROG', <<'EXPECT'); +use XS::APItest; +print "ok\n"; +my_exit(1); +print "not\n"; +PROG +ok +EXPECT +fresh_perl_is($prog, $expect); + +# C's EXIT_FAILURE ends up as SS$_ABORT (decimal 44) on VMS, which gets +# shifted to 4. Perl_my_exit (unlike Perl_my_failure_exit) does not +# have access to the vmsish pragmas to modify that behavior. + +my $exit_failure = $^O eq 'VMS' ? 4 : 1; +is($? >> 8, $exit_failure, "exit code plain my_exit"); + +($prog, $expect) = (<<'PROG', <<'EXPECT'); +use XS::APItest; +print "ok\n"; +call_sv( sub { my_exit(1); }, G_EVAL ); +print "not\n"; +PROG +ok +EXPECT +fresh_perl_is($prog, $expect); +is($? >> 8, $exit_failure, "exit code my_exit inside a call_sv with G_EVAL"); + diff --git a/global.sym b/global.sym index b554d8886d..6a44049c4e 100644 --- a/global.sym +++ b/global.sym @@ -148,6 +148,7 @@ Perl_gv_fullname3 Perl_gv_fullname4 Perl_gv_init Perl_gv_name_set +Perl_gv_try_downgrade Perl_gv_stashpv Perl_gv_stashpvn Perl_gv_stashsv @@ -243,6 +244,17 @@ Perl_is_utf8_xdigit Perl_is_utf8_mark Perl_leave_scope Perl_lex_end +Perl_lex_bufutf8 +Perl_lex_grow_linestr +Perl_lex_stuff_pvn +Perl_lex_stuff_sv +Perl_lex_unstuff +Perl_lex_read_to +Perl_lex_discard_to +Perl_lex_next_chunk +Perl_lex_peek_unichar +Perl_lex_read_unichar +Perl_lex_read_space Perl_op_null Perl_op_clear Perl_op_refcnt_lock @@ -363,6 +375,7 @@ Perl_vstringify Perl_vcmp Perl_ninstr Perl_op_free +Perl_pad_findmy Perl_find_rundefsvoffset Perl_pad_sv Perl_reentrant_size diff --git a/globvar.sym b/globvar.sym index cf557765e5..f1c81b816f 100644 --- a/globvar.sym +++ b/globvar.sym @@ -9,6 +9,7 @@ check fold fold_locale freq +keyword_plugin memory_wrap no_aelem no_dir_func @@ -2372,6 +2372,53 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) } /* +=for apidoc gv_try_downgrade + +If C<gv> is a typeglob containing only a constant sub, and is only +referenced from its package, and both the typeglob and the sub are +sufficiently ordinary, replace the typeglob (in the package) with a +placeholder that more compactly represents the same thing. This is meant +to be used when a placeholder has been upgraded, most likely because +something wanted to look at a proper code object, and it has turned out +to be a constant sub to which a proper reference is no longer required. + +=cut +*/ + +void +Perl_gv_try_downgrade(pTHX_ GV *gv) +{ + HV *stash; + CV *cv; + HEK *namehek; + SV **gvp; + PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; + if (SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && + !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) && + isGV_with_GP(gv) && GvGP(gv) && + GvMULTI(gv) && !GvINTRO(gv) && GvREFCNT(gv) == 1 && + !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && + GvEGV(gv) == gv && (stash = GvSTASH(gv)) && (cv = GvCV(gv)) && + !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && + CvSTASH(cv) == stash && CvGV(cv) == gv && + CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && + !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && + (namehek = GvNAME_HEK(gv)) && + (gvp = hv_fetch(stash, HEK_KEY(namehek), + HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) && + *gvp == (SV*)gv) { + SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); + SvREFCNT(gv) = 0; + sv_clear((SV*)gv); + SvREFCNT(gv) = 1; + SvFLAGS(gv) = SVt_IV|SVf_ROK; + SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - + STRUCT_OFFSET(XPVIV, xiv_iv)); + SvRV_set(gv, value); + } +} + +/* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 @@ -190,8 +190,13 @@ typedef U64TYPE U64; # define INT64_C(c) CAT2(c,L) # define UINT64_C(c) CAT2(c,UL) # else -# define INT64_C(c) ((I64TYPE)(c)) -# define UINT64_C(c) ((U64TYPE)(c)) +# if defined(_WIN64) && defined(_MSC_VER) +# define INT64_C(c) CAT2(c,I64) +# define UINT64_C(c) CAT2(c,UI64) +# else +# define INT64_C(c) ((I64TYPE)(c)) +# define UINT64_C(c) ((U64TYPE)(c)) +# endif # endif # endif # endif @@ -424,7 +429,7 @@ Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin) alphanumeric character (including underscore) or digit. =for apidoc Am|bool|isALPHA|char ch -Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin) +Returns a boolean indicating whether the C C<char> is a US-ASCII (Basic Latin) alphabetic character. =for apidoc Am|bool|isSPACE|char ch @@ -474,7 +479,9 @@ US-ASCII (Basic Latin) range are viewed as not having any case. # define isPUNCT(c) ispunct(c) # define isXDIGIT(c) isxdigit(c) # define toUPPER(c) toupper(c) +# define toUPPER_LATIN1_MOD(c) UNI_TO_NATIVE(PL_mod_latin1_uc[(U8) NATIVE_TO_UNI(c)]) # define toLOWER(c) tolower(c) +# define toLOWER_LATIN1(c) UNI_TO_NATIVE(PL_latin1_lc[(U8) NATIVE_TO_UNI(c)]) #else # define isUPPER(c) ((c) >= 'A' && (c) <= 'Z') # define isLOWER(c) ((c) >= 'a' && (c) <= 'z') @@ -485,6 +492,15 @@ US-ASCII (Basic Latin) range are viewed as not having any case. # define isPRINT(c) (((c) >= 32 && (c) < 127)) # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) + +/* Use table lookup for speed */ +# define toLOWER_LATIN1(c) (PL_latin1_lc[(U8) c]) + +/* Modified uc. Is correct uc except for three non-ascii chars which are + * all mapped to one of them, and these need special handling */ +# define toUPPER_LATIN1_MOD(c) (PL_mod_latin1_uc[(U8) c]) + +/* ASCII casing. */ # define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c)) # define toLOWER(c) (isUPPER(c) ? (c) + ('a' - 'A') : (c)) #endif diff --git a/hints/catamount.sh b/hints/catamount.sh index 1e5817172f..dd13f1a8a7 100644 --- a/hints/catamount.sh +++ b/hints/catamount.sh @@ -31,11 +31,11 @@ # 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.11.1 +# mkdir -p /opt/perl-catamount/lib/perl5/5.11.2 # mkdir -p /opt/perl-catamount/bin # cp *.h /opt/perl-catamount/include # cp libperl.a /opt/perl-catamount/lib -# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.11.1 +# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.11.2 # cp miniperl perl run.sh cc.sh /opt/perl-catamount/lib # # With the headers and the libperl.a you can embed Perl to your Catamount diff --git a/hints/linux.sh b/hints/linux.sh index c88f157eaa..d208129812 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -87,6 +87,11 @@ esac # Check if we're about to use Intel's ICC compiler case "`${cc:-cc} -V 2>&1`" in *"Intel(R) C++ Compiler"*|*"Intel(R) C Compiler"*) + # record the version, formats: + # icc (ICC) 10.1 20080801 + # icpc (ICC) 10.1 20080801 + # followed by a copyright on the second line + ccversion=`${cc:-cc} --version | sed -n -e 's/^icp\?c \((ICC) \)\?//p'` # This is needed for Configure's prototype checks to work correctly # The -mp flag is needed to pass various floating point related tests # The -no-gcc flag is needed otherwise, icc pretends (poorly) to be gcc @@ -2149,8 +2149,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); return entry; /* beware, hent_val is not set */ } - if (HeVAL(entry)) - SvREFCNT_dec(HeVAL(entry)); + SvREFCNT_dec(HeVAL(entry)); Safefree(HeKEY_hek(entry)); del_HE(entry); iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ diff --git a/intrpvar.h b/intrpvar.h index 10cd6b7d34..650eb62c8e 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -43,6 +43,9 @@ PERLVAR(Istack_base, SV **) PERLVAR(Istack_max, SV **) PERLVAR(Iscopestack, I32 *) /* scopes we've ENTERed */ +/* name of the scopes we've ENTERed. Only used with -DDEBUGGING, but needs to be + present always, as -DDEUBGGING must be binary compatible with non. */ +PERLVARI(Iscopestack_name, const char * *, NULL) PERLVAR(Iscopestack_ix, I32) PERLVAR(Iscopestack_max,I32) diff --git a/lib/.gitignore b/lib/.gitignore index b36be6f0fa..564bd091ed 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -376,12 +376,11 @@ /re.pm /threads /threads.pm -/unicore/Canonical.pl /unicore/CombiningClass.pl /unicore/Decomposition.pl -/unicore/Exact.pl +/unicore/Heavy.pl +/unicore/mktables.lst /unicore/Name.pl -/unicore/PVA.pl -/unicore/Properties +unicore/TestProp.pl /unicore/To /unicore/lib diff --git a/lib/Carp.pm b/lib/Carp.pm index 69d5c1f8ff..be27c6aea4 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -1,6 +1,6 @@ package Carp; -our $VERSION = '1.13'; +our $VERSION = '1.14'; our $MaxEvalLen = 0; our $Verbose = 0; @@ -43,7 +43,7 @@ sub longmess { # number of call levels to go back, so calls to longmess were off # by one. Other code began calling longmess and expecting this # behaviour, so the replacement has to emulate that behaviour. - my $call_pack = caller(); + my $call_pack = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->() : caller(); if ($Internal{$call_pack} or $CarpInternal{$call_pack}) { return longmess_heavy(@_); } @@ -55,7 +55,7 @@ sub longmess { sub shortmess { # Icky backwards compatibility wrapper. :-( - local @CARP_NOT = caller(); + local @CARP_NOT = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->() : caller(); shortmess_heavy(@_); }; @@ -70,7 +70,7 @@ sub caller_info { my %call_info; @call_info{ qw(pack file line sub has_args wantarray evaltext is_require) - } = caller($i); + } = defined (*CORE::GLOBAL::caller::{CODE}) ? *CORE::GLOBAL::{caller}->($i) : caller($i); unless (defined $call_info{pack}) { return (); @@ -149,7 +149,8 @@ sub long_error_loc { my $i; my $lvl = $CarpLevel; { - my $pkg = caller(++$i); + ++$i; + my $pkg = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->($i) : caller($i); unless(defined($pkg)) { # This *shouldn't* happen. if (%Internal) { @@ -224,8 +225,10 @@ sub short_error_loc { my $i = 1; my $lvl = $CarpLevel; { - my $called = caller($i++); - my $caller = caller($i); + + my $called = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->($i) : caller($i); + $i++; + my $caller = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->($i) : caller($i); return 0 unless defined($caller); # What happened? redo if $Internal{$caller}; diff --git a/lib/Carp.t b/lib/Carp.t index af07ed661c..63b43b21c5 100644 --- a/lib/Carp.t +++ b/lib/Carp.t @@ -8,7 +8,7 @@ my $Is_VMS = $^O eq 'VMS'; use Carp qw(carp cluck croak confess); -plan tests => 37; +plan tests => 39; ok 1; @@ -266,6 +266,18 @@ cluck "Bang!" cluck_undef (0, "undef", 2, undef, 4); +# check that Carp respects CORE::GLOBAL::caller override after Carp +# has been compiled +{ + my $accum = ''; + local *CORE::GLOBAL::caller = sub { local *__ANON__="fakecaller"; my @c=CORE::caller(@_); $c[0] ||= 'undef'; $accum .= "@c[0..3]\n"; return CORE::caller(($_[0]||0)+1) }; + eval "scalar caller()"; + like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in eval"); + $accum = ''; + A::long(); + like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in Carp"); +} + # line 1 "A" package A; sub short { diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm index 88e1493d3d..af16b1dd08 100644 --- a/lib/Dumpvalue.pm +++ b/lib/Dumpvalue.pm @@ -585,7 +585,7 @@ Prints a dump to the currently selected filehandle. $dumper->dumpValues($value1, $value2); -Same as C< $dumper->dumpValue([$value1, $value2]); >. +Same as C<< $dumper->dumpValue([$value1, $value2]); >>. =item stringify diff --git a/lib/Env.pm b/lib/Env.pm index eb9187fc90..deac5fc4b9 100644 --- a/lib/Env.pm +++ b/lib/Env.pm @@ -1,6 +1,6 @@ package Env; -our $VERSION = '1.00'; +our $VERSION = '1.01'; =head1 NAME @@ -132,8 +132,7 @@ sub TIEARRAY { sub FETCHSIZE { my ($self) = @_; - my @temp = split($sep, $ENV{$$self}); - return scalar(@temp); + return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g); } sub STORESIZE { @@ -161,6 +160,19 @@ sub STORE { return $value; } +sub EXISTS { + my ($self, $index) = @_; + return $index < $self->FETCHSIZE; +} + +sub DELETE { + my ($self, $index) = @_; + my @temp = split($sep, $ENV{$$self}); + my $value = splice(@temp, $index, 1, ()); + $ENV{$$self} = join($sep, @temp); + return $value; +} + sub PUSH { my $self = shift; my @temp = split($sep, $ENV{$$self}); @@ -232,4 +244,11 @@ sub FETCH { return $ENV{$$self . ';' . $index}; } +sub EXISTS { + my ($self, $index) = @_; + return $index < $self->FETCHSIZE; +} + +sub DELETE { } + 1; diff --git a/lib/File/Find.pm b/lib/File/Find.pm index eddedbd354..3cf14da2ab 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -448,7 +448,7 @@ sub contract_name { my $abs_name= $cdir . $fn; if (substr($fn,0,3) eq '../') { - 1 while $abs_name =~ s!/[^/]*/\.\./!/!; + 1 while $abs_name =~ s!/[^/]*/\.\./+!/!; } return $abs_name; diff --git a/lib/File/Find/t/find.t b/lib/File/Find/t/find.t index 6a71f98cb0..27e08bea1a 100644 --- a/lib/File/Find/t/find.t +++ b/lib/File/Find/t/find.t @@ -19,7 +19,7 @@ BEGIN { } my $test_count = 85; -$test_count += 114 if $symlink_exists; +$test_count += 119 if $symlink_exists; $test_count += 18 if $^O eq 'MSWin32'; $test_count += 2 if $^O eq 'MSWin32' and $symlink_exists; @@ -95,13 +95,17 @@ sub cleanup { file_path('fa', 'faa', 'faa_ord'), file_path('fa', 'fab', 'fab_ord'), file_path('fa', 'fab', 'faba', 'faba_ord'), + file_path('fa', 'fac', 'faca'), file_path('fb', 'fb_ord'), - file_path('fb', 'fba', 'fba_ord'); + file_path('fb', 'fba', 'fba_ord'), + file_path('fb', 'fbc', 'fbca'); rmdir dir_path('fa', 'faa'); rmdir dir_path('fa', 'fab', 'faba'); rmdir dir_path('fa', 'fab'); + rmdir dir_path('fa', 'fac'); rmdir dir_path('fa'); rmdir dir_path('fb', 'fba'); + rmdir dir_path('fb', 'fbc'); rmdir dir_path('fb'); } if ($need_updir) { @@ -893,3 +897,36 @@ if ($^O eq 'MSWin32') { File::Find::find( {wanted => \&wanted_File_Dir, no_chdir => 1}, $volume . topdir('fa')); Check( scalar(keys %Expect_File) == 0 ); } + + +if ($symlink_exists) { # Issue 68260 + print "# BUG 68260\n"; + MkDir (dir_path ('fa', 'fac'), 0770); + MkDir (dir_path ('fb', 'fbc'), 0770); + touch (file_path ('fa', 'fac', 'faca')); + if ($^O eq 'MacOS') { + CheckDie (symlink ('..::::..:fa:fac:faca', 'fb:fbc:fbca')); + } + else { + CheckDie (symlink ('..////../fa/fac/faca', 'fb/fbc/fbca')); + } + + use warnings; + my $dangling_symlink; + local $SIG {__WARN__} = sub { + local $" = " "; + $dangling_symlink ++ if "@_" =~ /dangling symbolic link/; + }; + + File::Find::find ( + { + wanted => sub {1;}, + follow => 1, + follow_skip => 2, + dangling_symlinks => 1, + }, + File::Spec -> curdir + ); + + Check (!$dangling_symlink); +} diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 7af5efa177..d65df19ca2 100644 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -185,7 +185,7 @@ use 5.009001; use Carp; $Carp::Internal{__PACKAGE__.""}++; -our $VERSION = 1.17; +our $VERSION = '1.18'; our $DEBUG; our $VERBOSE; our $PRETTY; @@ -377,7 +377,7 @@ my %msg; # strip formatting directives from =item line $header =~ s/[A-Z]<(.*?)>/$1/g; - my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header ); + my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?[fs])/, $header ); if (@toks > 1) { my $conlen = 0; for my $i (0..$#toks){ @@ -386,7 +386,7 @@ my %msg; $toks[$i] = '.'; } elsif( $toks[$i] eq '%d' ){ $toks[$i] = '\d+'; - } elsif( $toks[$i] eq '%s' ){ + } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){ $toks[$i] = $i == $#toks ? '.*' : '.*?'; } elsif( $toks[$i] =~ '%.(\d+)s' ){ $toks[$i] = ".{$1}"; diff --git a/lib/diagnostics.t b/lib/diagnostics.t index f30f70e073..ee0c160743 100644 --- a/lib/diagnostics.t +++ b/lib/diagnostics.t @@ -5,7 +5,7 @@ BEGIN { @INC = 'lib'; } -use Test::More tests => 2; +use Test::More tests => 3; BEGIN { use_ok('diagnostics') } @@ -16,3 +16,10 @@ eval { }; like( $@, qr/^Base class package "I::do::not::exist" is empty/); + +# Test for %.0f patterns in perldiag, added in 5.11.0 +close STDERR; +open STDERR, ">", \my $warning + or die "Couldn't redirect STDERR to var: $!"; +warn('gmtime(nan) too large'); +like $warning, qr/\(W overflow\) You called/, '%0.f patterns'; diff --git a/lib/legacy.pm b/lib/legacy.pm new file mode 100755 index 0000000000..67f287ffd7 --- /dev/null +++ b/lib/legacy.pm @@ -0,0 +1,203 @@ +package legacy; + +our $VERSION = '1.00'; + +$unicode8bit::hint_not_uni8bit = 0x00000800; + +my %legacy_bundle = ( + "5.10" => [qw(unicode8bit)], + "5.11" => [qw(unicode8bit)], +); + +my %legacy = ( 'unicode8bit' => '0' ); + +=head1 NAME + +legacy - Perl pragma to preserve legacy behaviors or enable new non-default behaviors + +=head1 SYNOPSIS + + use legacy ':5.10'; # Keeps semantics the same as in perl 5.10 + + use legacy qw(unicode8bit); + + no legacy; + + no legacy qw(unicode8bit); + +=head1 DESCRIPTION + +Some programs may rely on behaviors that for others are problematic or +even wrong. A new version of Perl may change behaviors from past ones, +and when it is viewed that the old way of doing things may be required +to still be supported, the new behavior will be able to be turned off by using +this pragma. + +Additionally, a new behavior may be supported in a new version of Perl, but +for whatever reason the default remains the old one. This pragma can enable +the new behavior. + +Like other pragmas (C<use feature>, for example), C<use legacy qw(foo)> will +only make the legacy behavior for "foo" available from that point to the end of +the enclosing block. + +=head2 B<use legacy> + +Preserve the old way of doing things when a new version of Perl is +released that would otherwise change the behavior. + +The one current possibility is: + +=head3 unicode8bit + +THIS IS SUBJECT TO CHANGE + +Use legacy semantics for the 128 characters on ASCII systems that have the 8th +bit set. (See L</EBCDIC platforms> below for EBCDIC systems.) Unless +C<S<use locale>> is specified, or the scalar containing such a character is +known by Perl to be encoded in UTF8, the semantics are essentially that the +characters have an ordinal number, and that's it. They are caseless, and +aren't anything: they're not controls, not letters, not punctuation, ..., not +anything. + +This behavior stems from when Perl did not support Unicode, and ASCII was the +only known character set outside of C<S<use locale>>. In order to not +possibly break pre_Unicode programs, these characters have retained their old +non-meanings, except when it is clear to Perl that Unicode is what is meant, +for example by calling utf8::upgrade() on a scalar, or if the scalar also +contains characters that are only available in Unicode. Then these 128 +characters take on their Unicode meanings. + +The problem with this behavior is that a scalar that encodes these characters +has a different meaning depending on if it is stored as utf8 or not. +In general, the internal storage method should not affect the +external behavior. + +The behavior is known to have effects on these areas: + +=over 4 + +=item * + +Changing the case of a scalar, that is, using C<uc()>, C<ucfirst()>, C<lc()>, +and C<lcfirst()>, or C<\L>, C<\U>, C<\u> and C<\l> in regular expression substitutions. + +=item * + +Using caseless (C</i>) regular expression matching + +=item * + +Matching a number of properties in regular expressions, such as C<\w> + +=item * + +User-defined case change mappings. You can create a C<ToUpper()> function, for +example, which overrides Perl's built-in case mappings. The scalar must be +encoded in utf8 for your function to actually be invoked. + +=back + +B<This lack of semantics for these characters is currently the default,> +outside of C<use locale>. See below for EBCDIC. +To turn on B<case changing semantics only> for these characters, use +C<S<no legacy>>. +The other legacy behaviors regarding these characters are currently +unaffected by this pragma. + +=head4 EBCDIC platforms + +On EBCDIC platforms, the situation is somewhat different. The legacy +semantics are whatever the underlying semantics of the native C language +library are. Each of the three EBCDIC encodings currently known by Perl is an +isomorph of the Latin-1 character set. That means every character in Latin-1 +has a corresponding EBCDIC equivalent, and vice-versa. Specifying C<S<no +legacy>> currently makes sure that all EBCDIC characters have the same +B<casing only> semantics as their corresponding Latin-1 characters. + +=head2 B<no legacy> + +Turn on a new behavior in a version of Perl that understands +it but has it turned off by default. For example, C<no legacy 'foo'> turns on +behavior C<foo> in the lexical scope of the pragma. C<no legacy> +without any modifier turns on all new behaviors known to the pragma. + +=head1 LEGACY BUNDLES + +It's possible to turn off all new behaviors past a given release by +using a I<legacy bundle>, which is the name of the release prefixed with +a colon, to distinguish it from an individual legacy behavior. + +Specifying sub-versions such as the C<0> in C<5.10.0> in legacy bundles has +no effect: legacy bundles are guaranteed to be the same for all sub-versions. + +Legacy bundles are not allowed with C<no legacy> + +=cut + +sub import { + my $class = shift; + if (@_ == 0) { + croak("No legacy behaviors specified"); + } + while (@_) { + my $name = shift(@_); + if (substr($name, 0, 1) eq ":") { + my $v = substr($name, 1); + if (!exists $legacy_bundle{$v}) { + $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/; + if (!exists $legacy_bundle{$v}) { + unknown_legacy_bundle(substr($name, 1)); + } + } + unshift @_, @{$legacy_bundle{$v}}; + next; + } + if (!exists $legacy{$name}) { + unknown_legacy($name); + } + $^H |= $unicode8bit::hint_not_uni8bit; # The only valid thing as of yet + } +} + + +sub unimport { + my $class = shift; + + # A bare C<no legacy> should disable *all* legacy behaviors + if (!@_) { + unshift @_, keys(%legacy); + } + + while (@_) { + my $name = shift; + if (substr($name, 0, 1) eq ":") { + croak(sprintf('Legacy bundles (%s) are not allowed in "no legacy"', + $name)); + } + if (!exists($legacy{$name})) { + unknown_legacy($name); + } + else { + $^H &= ~ $unicode8bit::hint_not_uni8bit; # The only valid thing now + } + } +} + +sub unknown_legacy { + my $legacy = shift; + croak(sprintf('Legacy "%s" is not supported by Perl %vd', $legacy, $^V)); +} + +sub unknown_legacy_bundle { + my $legacy = shift; + croak(sprintf('Legacy bundle "%s" is not supported by Perl %vd', + $legacy, $^V)); +} + +sub croak { + require Carp; + Carp::croak(@_); +} + +1; diff --git a/lib/legacy.t b/lib/legacy.t new file mode 100644 index 0000000000..1f0cce953e --- /dev/null +++ b/lib/legacy.t @@ -0,0 +1,142 @@ +use warnings; +use strict; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; +} + +plan(13312); # Determined by experimentation + +# Test the upper/lower/title case mappings for all characters 0-255. + +# First compute the case mappings without resorting to the functions we're +# testing. + +# Initialize the arrays so each $i maps to itself. +my @posix_to_upper; +for my $i (0 .. 255) { + $posix_to_upper[$i] = chr($i); +} +my @posix_to_lower += my @posix_to_title += my @latin1_to_upper += my @latin1_to_lower += my @latin1_to_title += @posix_to_upper; + +# Override the elements in the to_lower arrays that have different lower case +# mappings +for my $i (0x41 .. 0x5A) { + $posix_to_lower[$i] = chr(ord($posix_to_lower[$i]) + 32); + $latin1_to_lower[$i] = chr(ord($latin1_to_lower[$i]) + 32); +} + +# Same for upper and title +for my $i (0x61 .. 0x7A) { + $posix_to_upper[$i] = chr(ord($posix_to_upper[$i]) - 32); + $latin1_to_upper[$i] = chr(ord($latin1_to_upper[$i]) - 32); + $posix_to_title[$i] = chr(ord($posix_to_title[$i]) - 32); + $latin1_to_title[$i] = chr(ord($latin1_to_title[$i]) - 32); +} + +# And the same for those in the latin1 range +for my $i (0xC0 .. 0xD6, 0xD8 .. 0xDE) { + $latin1_to_lower[$i] = chr(ord($latin1_to_lower[$i]) + 32); +} +for my $i (0xE0 .. 0xF6, 0xF8 .. 0xFE) { + $latin1_to_upper[$i] = chr(ord($latin1_to_upper[$i]) - 32); + $latin1_to_title[$i] = chr(ord($latin1_to_title[$i]) - 32); +} + +# Override the abnormal cases. +$latin1_to_upper[0xB5] = chr(0x39C); +$latin1_to_title[0xB5] = chr(0x39C); +$latin1_to_upper[0xDF] = 'SS'; +$latin1_to_title[0xDF] = 'Ss'; +$latin1_to_upper[0xFF] = chr(0x178); +$latin1_to_title[0xFF] = chr(0x178); + +my $repeat = 25; # Length to make strings. + +# Create hashes of strings in several ranges, both for uc and lc. +my %posix; +$posix{'uc'} = 'A' x $repeat; +$posix{'lc'} = 'a' x $repeat ; + +my %cyrillic; +$cyrillic{'uc'} = chr(0x42F) x $repeat; +$cyrillic{'lc'} = chr(0x44F) x $repeat; + +my %latin1; +$latin1{'uc'} = chr(0xD8) x $repeat; +$latin1{'lc'} = chr(0xF8) x $repeat; + +my %empty; +$empty{'lc'} = $empty{'uc'} = ""; + +# Loop so prefix each character being tested with nothing, and the various +# strings; then loop for suffixes of those strings as well. +for my $prefix (\%empty, \%posix, \%cyrillic, \%latin1) { + for my $suffix (\%empty, \%posix, \%cyrillic, \%latin1) { + for my $i (0 .. 255) { # For each possible posix or latin1 character + my $cp = sprintf "U+%04X", $i; + + # First try using latin1 (Unicode) semantics. + no legacy "unicode8bit"; + + my $phrase = 'with uni8bit'; + my $char = chr($i); + my $pre_lc = $prefix->{'lc'}; + my $pre_uc = $prefix->{'uc'}; + my $post_lc = $suffix->{'lc'}; + my $post_uc = $suffix->{'uc'}; + my $to_upper = $pre_lc . $char . $post_lc; + my $expected_upper = $pre_uc . $latin1_to_upper[$i] . $post_uc; + my $to_lower = $pre_uc . $char . $post_uc; + my $expected_lower = $pre_lc . $latin1_to_lower[$i] . $post_lc; + + is (uc($to_upper), $expected_upper, + display("$cp: $phrase: uc($to_upper) eq $expected_upper")); + is (lc($to_lower), $expected_lower, + display("$cp: $phrase: lc($to_lower) eq $expected_lower")); + + if ($pre_uc eq "") { # Title case if null prefix. + my $expected_title = $latin1_to_title[$i] . $post_lc; + is (ucfirst($to_upper), $expected_title, + display("$cp: $phrase: ucfirst($to_upper) eq $expected_title")); + my $expected_lcfirst = $latin1_to_lower[$i] . $post_uc; + is (lcfirst($to_lower), $expected_lcfirst, + display("$cp: $phrase: lcfirst($to_lower) eq $expected_lcfirst")); + } + + # Then try with posix semantics. + use legacy "unicode8bit"; + $phrase = 'no uni8bit'; + + # These don't contribute anything in this case. + next if $suffix == \%cyrillic; + next if $suffix == \%latin1; + next if $prefix == \%cyrillic; + next if $prefix == \%latin1; + + $expected_upper = $pre_uc . $posix_to_upper[$i] . $post_uc; + $expected_lower = $pre_lc . $posix_to_lower[$i] . $post_lc; + + is (uc($to_upper), $expected_upper, + display("$cp: $phrase: uc($to_upper) eq $expected_upper")); + is (lc($to_lower), $expected_lower, + display("$cp: $phrase: lc($to_lower) eq $expected_lower")); + + if ($pre_uc eq "") { + my $expected_title = $posix_to_title[$i] . $post_lc; + is (ucfirst($to_upper), $expected_title, + display("$cp: $phrase: ucfirst($to_upper) eq $expected_title")); + my $expected_lcfirst = $posix_to_lower[$i] . $post_uc; + is (lcfirst($to_lower), $expected_lcfirst, + display("$cp: $phrase: lcfirst($to_lower) eq $expected_lcfirst")); + } + } + } +} diff --git a/lib/unicore/Makefile b/lib/unicore/Makefile index b73d3b8089..4a3cdd373b 100644 --- a/lib/unicore/Makefile +++ b/lib/unicore/Makefile @@ -1,12 +1,6 @@ all: - ../../miniperl -I../../lib ./mktables - -TestProp.pl: mktables UnicodeData.txt Scripts.txt Blocks.txt PropList.txt - ../../miniperl -I../../lib ./mktables -maketest - -test: TestProp.pl - ../../miniperl -I../../lib TestProp.pl + ../../miniperl -I../../lib ./mktables -P ../../pod -maketest -makelist -p clean: - rm -f *.pl */*.pl */*/*.pl - rm -f Properties + rm -fr *.pl To lib + rm -f ../../pod/perluniprops.pod ../../t/re/uniprops.t mktables.lst diff --git a/lib/unicore/README.perl b/lib/unicore/README.perl index 96b2caa2fc..7515825c6f 100644 --- a/lib/unicore/README.perl +++ b/lib/unicore/README.perl @@ -1,11 +1,17 @@ The *.txt files were copied from - http://www.unicode.org/Public/5.1.0/ucd + ftp://www.unicode.org/Public/UNIDATA -and subdirectories 'extracted' and 'auxiliary' as of Unicode 5.1.0 (March 2008). +with subdirectories 'extracted' and 'auxiliary' -The big file, Unihan.txt (28 MB, 5.8 MB zip) was not included due to space -considerations. Also NOT included were any *.html files and *Test.txt files. +The Unihan files were not included due to space considerations. Also NOT +included were any *.html files and *Test.txt files. It is possible to add the +Unihan files, and edit mktables (see instructions near its beginning) to look +at them. + +The file 'version' should exist and be a single line with the Unicode version, +like: +5.2.0 To be 8.3 filesystem friendly, the names of some of the input files have been changed from the values that are in the Unicode DB: @@ -27,42 +33,68 @@ mv extracted/DerivedLineBreak.txt extracted/DLineBreak.txt mv extracted/DerivedNumericType.txt extracted/DNumType.txt mv extracted/DerivedNumericValues.txt extracted/DNumValues.txt -The names of files, such as test files, that are not used by mktables are not -changed, and will not work correctly on 8.3 filesystems. +If you have the Unihan database (5.2 and above), you should also do the +following: -The file 'version' should exist and be a single line with the Unicode version, -like -5.1.0 +mv Unihan_DictionaryIndices.txt UnihanIndicesDictionary.txt +mv Unihan_DictionaryLikeData.txt UnihanDataDictionaryLike.txt +mv Unihan_IRGSources.txt UnihanIRGSources.txt +mv Unihan_NumericValues.txt UnihanNumericValues.txt +mv Unihan_OtherMappings.txt UnihanOtherMappings.txt +mv Unihan_RadicalStrokeCounts.txt UnihanRadicalStrokeCounts.txt +mv Unihan_Readings.txt UnihanReadings.txt +mv Unihan_Variants.txt UnihanVariants.txt + +If you download everything, the names of files, such as test files, that are +not used by mktables are not changed by the above, and will not work correctly +as-is on 8.3 filesystems. + +mktables is used to generate the tables used by the rest of Perl. It will warn +you about any *.txt files in the directory substructure that it doesn't know +about. You should remove any so-identified, or edit mktables to add them to +its lists to process. You can run + + mktables -globlist + +to have it try to process these tables generically. + +If any files are added, deleted, or their names change, you must run -NOTE: If you modify the input file set you should also run - mktables -makelist - -which will recreate the mktables.lst file which is used to speed up -the build process. + +to generate a new list of all the files. FOR PUMPKINS -The files are inter-related. If you take the latest UnicodeData.txt, for example, -but leave the older versions of other files, there can be subtle problems. +The files are inter-related. If you take the latest UnicodeData.txt, for +example, but leave the older versions of other files, there can be subtle +problems. + +When moving to a new version of Unicode, you need to update 'version' by hand + + p4 edit version + ... + +You should look in the Unicode release notes (which are probably towards the +bottom of http://www.unicode.org/reports/tr44/) to see if any properties have +newly been moved to be Obsolete, Deprecated, or Stabilized. The full names for +these should be added to the respective lists near the beginning of mktables, +using an 'if' to add them for just this Unicode version going forward, so that +mktables can continue to be used for earlier Unicode versions. + +When putting out a new Perl release, think about if any of the Deprecated +properties should be moved to Suppressed. The *.pl files are generated from the *.txt files by the mktables script, more recently done during the Perl build process, but if you want to try the old manual way: cd lib/unicore - cp .../UnicodeOriginal/*.txt . - rm NormalizationTest.txt Unihan.txt Derived*.txt - p4 edit Properties *.pl */*.pl - perl ./mktables + p4 edit *.pl */*.pl */*/*.pl + perl ./mktables -P ../../pod -T ../../t/re/uniprops.t -makelist p4 revert -a cd ../.. perl Porting/manicheck - -You need to update version by hand - - p4 edit version - ... If any new (or deleted, unlikely but not impossible) *.pl files are indicated: @@ -78,4 +110,4 @@ And finally: p4 submit -- -jhi@iki.fi; updated by nick@ccl4.org +jhi@iki.fi; updated by nick@ccl4.org, public@khwilliamson.com diff --git a/lib/unicore/mktables b/lib/unicore/mktables index 6ab4e70480..44355de51b 100644 --- a/lib/unicore/mktables +++ b/lib/unicore/mktables @@ -1,2232 +1,13700 @@ -## !!!!!!!!!!!!!! IF YOU MODIFY THIS FILE !!!!!!!!!!!!!!!!!!!!!!!!! -## Any files created or read by this program should be listed in 'mktables.lst' - #!/usr/bin/perl -w -require 5.008; # Needs pack "U". Probably safest to run on 5.8.x + +# !!!!!!!!!!!!!! IF YOU MODIFY THIS FILE !!!!!!!!!!!!!!!!!!!!!!!!! +# Any files created or read by this program should be listed in 'mktables.lst' +# Use -makelist to regenerate it. + +# Needs 'no overloading' to run faster on miniperl. Code commented out at the +# subroutine objaddr can be used instead to work as far back (untested) as +# 5.8: needs pack "U". +require 5.010_001; use strict; +use warnings; use Carp; +use File::Find; +use File::Path; use File::Spec; -use Text::Tabs (); ## using this makes the files about half the size - -## -## mktables -- create the runtime Perl Unicode files (lib/unicore/**/*.pl) -## from the Unicode database files (lib/unicore/*.txt). -## - -## "Fuzzy" means this section in Unicode TR18: -## -## The recommended names for UCD properties and property values are in -## PropertyAliases.txt [Prop] and PropertyValueAliases.txt -## [PropValue]. There are both abbreviated names and longer, more -## descriptive names. It is strongly recommended that both names be -## recognized, and that loose matching of property names be used, -## whereby the case distinctions, whitespace, hyphens, and underbar -## are ignored. - -## Base names already used in lib/gc_sc (for avoiding 8.3 conflicts) -my %BaseNames; - -## -## Process any args. -## -my $Verbose = 0; -my $MakeTestScript = 0; -my $AlwaysWrite = 0; -my $UseDir = ""; -my $FileList = "$0.lst"; -my $MakeList = 0; - -while (@ARGV) -{ +use Text::Tabs; + +sub DEBUG () { 0 } # Set to 0 for production; 1 for development + +########################################################################## +# +# mktables -- create the runtime Perl Unicode files (lib/unicore/.../*.pl), +# from the Unicode database files (lib/unicore/.../*.txt), It also generates +# a pod file and a .t file +# +# The structure of this file is: +# First these introductory comments; then +# code needed for everywhere, such as debugging stuff; then +# code to handle input parameters; then +# data structures likely to be of external interest (some of which depend on +# the input parameters, so follows them; then +# more data structures and subroutine and package (class) definitions; then +# the small actual loop to process the input files and finish up; then +# a __DATA__ section, for the .t tests +# +# This program works on all releases of Unicode through at least 5.2. The +# outputs have been scrutinized most intently for release 5.1. The others +# have been checked for somewhat more than just sanity. It can handle all +# existing Unicode character properties in those releases. +# +# This program needs to be able to run under miniperl. Therefore, it uses a +# minimum of other modules, and hence implements some things itself that could +# be gotten from CPAN +# +# This program uses inputs published by the Unicode Consortium. These can +# change incompatibly between releases without the Perl maintainers realizing +# it. Therefore this program is now designed to try to flag these. It looks +# at the directories where the inputs are, and flags any unrecognized files. +# It keeps track of all the properties in the files it handles, and flags any +# that it doesn't know how to handle. It also flags any input lines that +# don't match the expected syntax, among other checks. +# It is also designed so if a new input file matches one of the known +# templates, one hopefully just needs to add it to a list to have it +# processed. +# +# It tries to keep fatal errors to a minimum, to generate something usable for +# testing purposes. It always looks for files that could be inputs, and will +# warn about any that it doesn't know how to handle (the -q option suppresses +# the warning). +# +# This program is mostly about Unicode character (or code point) properties. +# A property describes some attribute or quality of a code point, like if it +# is lowercase or not, its name, what version of Unicode it was first defined +# in, or what its uppercase equivalent is. Unicode deals with these disparate +# possibilities by making all properties into mappings from each code point +# into some corresponding value. In the case of it being lowercase or not, +# the mapping is either to 'Y' or 'N' (or various synonyms thereof). Each +# property maps each Unicode code point to a single value, called a "property +# value". (Hence each Unicode property is a true mathematical function with +# exactly one value per code point.) +# +# When using a property in a regular expression, what is desired isn't the +# mapping of the code point to its property's value, but the reverse (or the +# mathematical "inverse relation"): starting with the property value, "Does a +# code point map to it?" These are written in a "compound" form: +# \p{property=value}, e.g., \p{category=punctuation}. This program generates +# files containing the lists of code points that map to each such regular +# expression property value, one file per list +# +# There is also a single form shortcut that Perl adds for many of the commonly +# used properties. This happens for all binary properties, plus script, +# general_category, and block properties. +# +# Thus the outputs of this program are files. There are map files, mostly in +# the 'To' directory; and there are list files for use in regular expression +# matching, all in subdirectories of the 'lib' directory, with each +# subdirectory being named for the property that the lists in it are for. +# Bookkeeping, test, and documentation files are also generated. + +my $matches_directory = 'lib'; # Where match (\p{}) files go. +my $map_directory = 'To'; # Where map files go. + +# DATA STRUCTURES +# +# The major data structures of this program are Property, of course, but also +# Table. There are two kinds of tables, very similar to each other. +# "Match_Table" is the data structure giving the list of code points that have +# a particular property value, mentioned above. There is also a "Map_Table" +# data structure which gives the property's mapping from code point to value. +# There are two structures because the match tables need to be combined in +# various ways, such as constructing unions, intersections, complements, etc., +# and the map ones don't. And there would be problems, perhaps subtle, if +# a map table were inadvertently operated on in some of those ways. +# The use of separate classes with operations defined on one but not the other +# prevents accidentally confusing the two. +# +# At the heart of each table's data structure is a "Range_List", which is just +# an ordered list of "Ranges", plus ancillary information, and methods to +# operate on them. A Range is a compact way to store property information. +# Each range has a starting code point, an ending code point, and a value that +# is meant to apply to all the code points between the two end points, +# inclusive. For a map table, this value is the property value for those +# code points. Two such ranges could be written like this: +# 0x41 .. 0x5A, 'Upper', +# 0x61 .. 0x7A, 'Lower' +# +# Each range also has a type used as a convenience to classify the values. +# Most ranges in this program will be Type 0, or normal, but there are some +# ranges that have a non-zero type. These are used only in map tables, and +# are for mappings that don't fit into the normal scheme of things. Mappings +# that require a hash entry to communicate with utf8.c are one example; +# another example is mappings for charnames.pm to use which indicate a name +# that is algorithmically determinable from its code point (and vice-versa). +# These are used to significantly compact these tables, instead of listing +# each one of the tens of thousands individually. +# +# In a match table, the value of a range is irrelevant (and hence the type as +# well, which will always be 0), and arbitrarily set to the null string. +# Using the example above, there would be two match tables for those two +# entries, one named Upper would contain the 0x41..0x5A range, and the other +# named Lower would contain 0x61..0x7A. +# +# Actually, there are two types of range lists, "Range_Map" is the one +# associated with map tables, and "Range_List" with match tables. +# Again, this is so that methods can be defined on one and not the other so as +# to prevent operating on them in incorrect ways. +# +# Eventually, most tables are written out to files to be read by utf8_heavy.pl +# in the perl core. All tables could in theory be written, but some are +# suppressed because there is no current practical use for them. It is easy +# to change which get written by changing various lists that are near the top +# of the actual code in this file. The table data structures contain enough +# ancillary information to allow them to be treated as separate entities for +# writing, such as the path to each one's file. There is a heading in each +# map table that gives the format of its entries, and what the map is for all +# the code points missing from it. (This allows tables to be more compact.) + +# The Property data structure contains one or more tables. All properties +# contain a map table (except the $perl property which is a +# pseudo-property containing only match tables), and any properties that +# are usable in regular expression matches also contain various matching +# tables, one for each value the property can have. A binary property can +# have two values, True and False (or Y and N, which are preferred by Unicode +# terminology). Thus each of these properties will have a map table that +# takes every code point and maps it to Y or N (but having ranges cuts the +# number of entries in that table way down), and two match tables, one +# which has a list of all the code points that map to Y, and one for all the +# code points that map to N. (For each of these, a third table is also +# generated for the pseudo Perl property. It contains the identical code +# points as the Y table, but can be written, not in the compound form, but in +# a "single" form like \p{IsUppercase}.) Many properties are binary, but some +# properties have several possible values, some have many, and properties like +# Name have a different value for every named code point. Those will not, +# unless the controlling lists are changed, have their match tables written +# out. But all the ones which can be used in regular expression \p{} and \P{} +# constructs will. Generally a property will have either its map table or its +# match tables written but not both. Again, what gets written is controlled +# by lists which can easily be changed. + +# For information about the Unicode properties, see Unicode's UAX44 document: + +my $unicode_reference_url = 'http://www.unicode.org/reports/tr44/'; + +# As stated earlier, this program will work on any release of Unicode so far. +# Most obvious problems in earlier data have NOT been corrected except when +# necessary to make Perl or this program work reasonably. For example, no +# folding information was given in early releases, so this program uses the +# substitute of lower case, just so that a regular expression with the /i +# option will do something that actually gives the right results in many +# cases. There are also a couple other corrections for version 1.1.5, +# commented at the point they are made. As an example of corrections that +# weren't made (but could be) is this statement from DerivedAge.txt: "The +# supplementary private use code points and the non-character code points were +# assigned in version 2.0, but not specifically listed in the UCD until +# versions 3.0 and 3.1 respectively." (To be precise it was 3.0.1 not 3.0.0) +# More information on Unicode version glitches is further down in these +# introductory comments. +# +# This program works on all properties as of 5.2, though the files for some +# are suppressed from apparent lack of demand for. You can change which are +# output by changing lists in this program. + +# The old version of mktables emphasized the term "Fuzzy" to mean Unocde's +# loose matchings rules (from Unicode TR18): +# +# The recommended names for UCD properties and property values are in +# PropertyAliases.txt [Prop] and PropertyValueAliases.txt +# [PropValue]. There are both abbreviated names and longer, more +# descriptive names. It is strongly recommended that both names be +# recognized, and that loose matching of property names be used, +# whereby the case distinctions, whitespace, hyphens, and underbar +# are ignored. +# The program still allows Fuzzy to override its determination of if loose +# matching should be used, but it isn't currently used, as it is no longer +# needed; the calculations it makes are good enough. + +# SUMMARY OF HOW IT WORKS: +# +# Process arguments +# +# A list is constructed containing each input file that is to be processed +# +# Each file on the list is processed in a loop, using the associated handler +# code for each: +# The PropertyAliases.txt and PropValueAliases.txt files are processed +# first. These files name the properties and property values. +# Objects are created of all the property and property value names +# that the rest of the input should expect, including all synonyms. +# The other input files give mappings from properties to property +# values. That is, they list code points and say what the mapping +# is under the given property. Some files give the mappings for +# just one property; and some for many. This program goes through +# each file and populates the properties from them. Some properties +# are listed in more than one file, and Unicode has set up a +# precedence as to which has priority if there is a conflict. Thus +# the order of processing matters, and this program handles the +# conflict possibility by processing the overriding input files +# last, so that if necessary they replace earlier values. +# After this is all done, the program creates the property mappings not +# furnished by Unicode, but derivable from what it does give. +# The tables of code points that match each property value in each +# property that is accessible by regular expressions are created. +# The Perl-defined properties are created and populated. Many of these +# require data determined from the earlier steps +# Any Perl-defined synonyms are created, and name clashes between Perl +# and Unicode are reconciled. +# All the properties are written to files +# Any other files are written, and final warnings issued. + +# As mentioned above, some properties are given in more than one file. In +# particular, the files in the extracted directory are supposedly just +# reformattings of the others. But they contain information not easily +# derivable from the other files, including results for Unihan, which this +# program doesn't ordinarily look at, and for unassigned code points. They +# also have historically had errors or been incomplete. In an attempt to +# create the best possible data, this program thus processes them first to +# glean information missing from the other files; then processes those other +# files to override any errors in the extracted ones. + +# For clarity, a number of operators have been overloaded to work on tables: +# ~ means invert (take all characters not in the set). The more +# conventional '!' is not used because of the possibility of confusing +# it with the actual boolean operation. +# + means union +# - means subtraction +# & means intersection +# The precedence of these is the order listed. Parentheses should be +# copiously used. These are not a general scheme. The operations aren't +# defined for a number of things, deliberately, to avoid getting into trouble. +# Operations are done on references and affect the underlying structures, so +# that the copy constructors for them have been overloaded to not return a new +# clone, but the input object itself. + +# The bool operator is deliberately not overloaded to avoid confusion with +# "should it mean if the object merely exists, or also is non-empty?". + +# +# WHY CERTAIN DESIGN DECISIONS WERE MADE + +# XXX These comments need more work. +# +# Why have files written out for binary 'N' matches? +# For binary properties, if you know the mapping for either Y or N; the +# other is trivial to construct, so could be done at Perl run-time instead +# of having a file for it. That is, if someone types in \p{foo: N}, Perl +# could translate that to \P{foo: Y} and not need a file. The problem is +# communicating to Perl that a given property is binary. Perl can't figure +# it out from looking at the N (or No), as some non-binary properties have +# these as property values. +# Why +# There are several types of properties, based on what form their values can +# take on. These are described in more detail below in the DATA STRUCTURES +# section of these comments, but for now, you should know that there are +# string properties, whose values are strings of one or more code points (such +# as the Uppercase_mapping property); every other property maps to some other +# form, like true or false, or a number, or a name, etc. The reason there are +# two directories for map files is because of the way utf8.c works. It +# expects that any files there are string properties, that is that the +# mappings are each to one code point, with mappings in multiple code points +# handled specially in an extra hash data structure. Digit.pl is a table that +# is written there for historical reasons, even though it doesn't fit that +# mold. Thus it can't currently be looked at by the Perl core. +# +# There are no match tables generated for matches of the null string. These +# would like like \p{JSN=}. Perhaps something like them could be added if +# necessary. The JSN does have a real code point U+110B that maps to the null +# string, but it is a contributory property, and therefore not output by +# default. +# +# DEBUGGING +# +# XXX Add more stuff here. use perl instead of miniperl to find problems with +# Scalar::Util + +# FUTURE ISSUES +# +# The program would break if Unicode were to change its names so that +# interior white space, underscores, or dashes differences were significant +# within property and property value names. +# +# It might be easier to use the xml versions of the UCD if this program ever +# would need heavy revision, and the ability to handle old versions was not +# required. +# +# There is the potential for name collisions, in that Perl has chosen names +# that Unicode could decide it also likes. There have been such collisions in +# the past, with mostly Perl deciding to adopt the Unicode definition of the +# name. However in the 5.2 Unicode beta testing, there were a number of such +# collisions, which were withdrawn before the final release, because of Perl's +# and other's protests. These all involved new properties which began with +# 'Is'. Based on the protests, Unicode is unlikely to try that again. Also, +# many of the Perl-defined synonyms, like Any, Word, etc, are listed in a +# Unicode document, so they are unlikely to be used by Unicode for another +# purpose. However, they might try something beginning with 'In', or use any +# of the other Perl-defined properties. This program will warn you of name +# collisions, and refuse to generate tables with them, but manual intervention +# will be required in this event. One scheme that could be implemented, if +# necessary, would be to have this program generate another file, or add a +# field to mktables.lst that gives the date of first definition of a property. +# Each new release of Unicode would use that file as a basis for the next +# iteration. And the Perl synonym addition code could sort based on the age +# of the property, so older properties get priority, and newer ones that clash +# would be refused; hence existing code would not be impacted, and some other +# synonym would have to be used for the new property. This is ugly, and +# manual intervention would certainly be easier to do in the short run; lets +# hope it never comes to this. + +# A NOTE ON UNIHAN +# +# This program can generate tables from the Unihan database. But it doesn't +# by default, letting the CPAN module Unicode::Unihan handle them. 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'. This program will read those file(s) if present, but it needs to +# know which of the many properties in the file(s) should have tables created +# for them. It will create tables for any properties listed in +# PropertyAliases.txt and PropValueAliases.txt, plus any listed in the +# @cjk_properties array and the @cjk_property_values array. Thus, if a +# property you want is not in those files of the release you are building +# against, you must add it to those two arrays. Starting in 4.0, the +# Unicode_Radical_Stroke was listed in those files, so if the Unihan database +# is present in the directory, a table will be generated for that property. +# In 5.2, several more properties were added. For your convenience, the two +# arrays are initialized with all the 5.2 listed properties that are also in +# earlier releases. But these are commented out. You can just uncomment the +# ones you want, or use them as a template for adding entries for other +# properties. +# +# You may need to adjust the entries to suit your purposes. setup_unihan(), +# and filter_unihan_line() are the functions where this is done. This program +# already does some adjusting to make the lines look more like the rest of the +# Unicode DB; You can see what that is in filter_unihan_line() +# +# There is a bug in the 3.2 data file in which some values for the +# kPrimaryNumeric property have commas and an unexpected comment. A filter +# could be added for these; or for a particular installation, the Unihan.txt +# file could be edited to fix them. +# have to be +# +# HOW TO ADD A FILE + +# Unicode Versions Notes + +# alpha's numbers halve in 2.1.9, answer cjk block at 4E00 were removed from PropList; not changed, could add gc Letter, put back in in 3.1.0 +# Some versions of 2.1.x Jamo.txt have the wrong value for 1105, which causes +# real problems for the algorithms for Jamo calculations, so it is changed +# here. +# White space vs Space. in 3.2 perl has +205F=medium math space, fixed in 4.0, and ok in 3.1.1 because not there in unicode. synonym introduced in 4.1 +# ATBL = 202. 202 changed to ATB, and all code points stayed there. So if you were useing ATBL you were out of luck. +# Hrkt Katakana_Or_Hiragana came in 4.01, before was Unknown. +# +# The default for missing code points for BidiClass is complicated. Starting +# in 3.1.1, the derived file DBidiClass.txt handles this, but this program +# tries to do the best it can for earlier releases. It is done in +# process_PropertyAliases() +# +############################################################################## + +my $UNDEF = ':UNDEF:'; # String to print out for undefined values in tracing + # and errors +my $MAX_LINE_WIDTH = 78; + +# Debugging aid to skip most files so as to not be distracted by them when +# concentrating on the ones being debugged. Add +# non_skip => 1, +# to the constructor for those files you want processed when you set this. +# Files with a first version number of 0 are special: they are always +# processed regardless of the state of this flag. +my $debug_skip = 0; + +# Set to 1 to enable tracing. +our $to_trace = 0; + +{ # Closure for trace: debugging aid + my $print_caller = 1; # ? Include calling subroutine name + my $main_with_colon = 'main::'; + my $main_colon_length = length($main_with_colon); + + sub trace { + return unless $to_trace; # Do nothing if global flag not set + + my @input = @_; + + local $DB::trace = 0; + $DB::trace = 0; # Quiet 'used only once' message + + my $line_number; + + # Loop looking up the stack to get the first non-trace caller + my $caller_line; + my $caller_name; + my $i = 0; + do { + $line_number = $caller_line; + (my $pkg, my $file, $caller_line, my $caller) = caller $i++; + $caller = $main_with_colon unless defined $caller; + + $caller_name = $caller; + + # get rid of pkg + $caller_name =~ s/.*:://; + if (substr($caller_name, 0, $main_colon_length) + eq $main_with_colon) + { + $caller_name = substr($caller_name, $main_colon_length); + } + + } until ($caller_name ne 'trace'); + + # If the stack was empty, we were called from the top level + $caller_name = 'main' if ($caller_name eq "" + || $caller_name eq 'trace'); + + my $output = ""; + foreach my $string (@input) { + #print STDERR __LINE__, ": ", join ", ", @input, "\n"; + if (ref $string eq 'ARRAY' || ref $string eq 'HASH') { + $output .= simple_dumper($string); + } + else { + $string = "$string" if ref $string; + $string = $UNDEF unless defined $string; + chomp $string; + $string = '""' if $string eq ""; + $output .= " " if $output ne "" + && $string ne "" + && substr($output, -1, 1) ne " " + && substr($string, 0, 1) ne " "; + $output .= $string; + } + } + + if ($print_caller) { + if (defined $line_number) { + print STDERR sprintf "%4d: ", $line_number; + } + else { + print STDERR " "; + } + $caller_name .= ": "; + print STDERR $caller_name; + } + + print STDERR $output, "\n"; + return; + } +} + +# This is for a rarely used development feature that allows you to compare two +# versions of the Unicode standard without having to deal with changes caused +# by the code points introduced in the later verson. Change the 0 to a SINGLE +# dotted Unicode release number (e.g. 2.1). Only code points introduced in +# that release and earlier will be used; later ones are thrown away. You use +# the version number of the earliest one you want to compare; then run this +# program on directory structures containing each release, and compare the +# outputs. These outputs will therefore include only the code points common +# to both releases, and you can see the changes caused just by the underlying +# release semantic changes. For versions earlier than 3.2, you must copy a +# version of DAge.txt into the directory. +my $string_compare_versions = DEBUG && 0; # e.g., v2.1; +my $compare_versions = DEBUG + && $string_compare_versions + && pack "C*", split /\./, $string_compare_versions; + +sub uniques { + # Returns non-duplicated input values. From "Perl Best Practices: + # Encapsulated Cleverness". p. 455 in first edition. + + my %seen; + return grep { ! $seen{$_}++ } @_; +} + +$0 = File::Spec->canonpath($0); + +my $make_test_script = 0; # ? Should we output a test script +my $write_unchanged_files = 0; # ? Should we update the output files even if + # we don't think they have changed +my $use_directory = ""; # ? Should we chdir somewhere. +my $pod_directory; # input directory to store the pod file. +my $pod_file = 'perluniprops'; +my $t_path; # Path to the .t test file +my $file_list = 'mktables.lst'; # File to store input and output file names. + # This is used to speed up the build, by not + # executing the main body of the program if + # nothing on the list has changed since the + # previous build +my $make_list = 1; # ? Should we write $file_list. Set to always + # make a list so that when the pumpking is + # preparing a release, s/he won't have to do + # special things +my $glob_list = 0; # ? Should we try to include unknown .txt files + # in the input. +my $output_range_counts = 1; # ? Should we include the number of code points + # in ranges in the output +# Verbosity levels; 0 is quiet +my $NORMAL_VERBOSITY = 1; +my $PROGRESS = 2; +my $VERBOSE = 3; + +my $verbosity = $NORMAL_VERBOSITY; + +# Process arguments +while (@ARGV) { my $arg = shift @ARGV; if ($arg eq '-v') { - $Verbose = 1; - } elsif ($arg eq '-q') { - $Verbose = 0; - } elsif ($arg eq '-w') { - $AlwaysWrite = 1; # update the files even if they havent changed - $FileList = ""; - } elsif ($arg eq '-check') { + $verbosity = $VERBOSE; + } + elsif ($arg eq '-p') { + $verbosity = $PROGRESS; + $| = 1; # Flush buffers as we go. + } + elsif ($arg eq '-q') { + $verbosity = 0; + } + elsif ($arg eq '-w') { + $write_unchanged_files = 1; # update the files even if havent changed + } + elsif ($arg eq '-check') { my $this = shift @ARGV; my $ok = shift @ARGV; if ($this ne $ok) { print "Skipping as check params are not the same.\n"; exit(0); } - } elsif ($arg eq '-maketest') { - $MakeTestScript = 1; - } elsif ($arg eq '-makelist') { - $MakeList = 1; - } elsif ($arg eq '-C' && defined ($UseDir = shift)) { - -d $UseDir or die "Unknown directory '$UseDir'"; - } elsif ($arg eq '-L' && defined ($FileList = shift)) { - -e $FileList or die "Filelist '$FileList' doesn't appear to exist!"; - } else { - die "usage: $0 [-v|-q|-w|-C dir|-L filelist] [-maketest] [-makelist]\n", - " -v : Verbose Mode\n", - " -q : Quiet Mode\n", - " -w : Write files regardless\n", - " -maketest : Make test script\n", - " -makelist : Rewrite the file list based on current setup\n", - " -L filelist : Use this file list, (defaults to $0.lst)\n", - " -C dir : Change to this directory before proceeding\n", - " -check A B : Executes only if A and B are the same\n"; - } -} - -if ($FileList) { - print "Reading file list '$FileList'\n" - if $Verbose; - open my $fh,"<",$FileList or die "Failed to read '$FileList':$!"; - my @input; - my @output; - for my $list ( \@input, \@output ) { - while (<$fh>) { - s/^ \s+ | \s+ $//xg; - next if /^ \s* (?: \# .* )? $/x; - last if /^ =+ $/x; - my ( $file ) = split /\t/, $_; - push @$list, $file; - } - my %dupe; - @$list = grep !$dupe{ $_ }++, @$list; - } - close $fh; - die "No input or output files in '$FileList'!" - if !@input or !@output; - if ( $MakeList ) { - foreach my $file (@output) { - unlink $file; - } - } - if ( $Verbose ) { - print "Expecting ".scalar( @input )." input files. ", - "Checking ".scalar( @output )." output files.\n"; - } - # we set maxtime to be the youngest input file, including $0 itself. - my $maxtime = -M $0; # do this before the chdir! - if ($UseDir) { - chdir $UseDir or die "Failed to chdir to '$UseDir':$!"; - } - foreach my $in (@input) { - my $time = -M $in; - die "Missing input file '$in'" unless defined $time; - $maxtime = $time if $maxtime < $time; - } - - # now we check to see if any output files are older than maxtime, if - # they are we need to continue on, otherwise we can presumably bail. - my $ok = 1; - foreach my $out (@output) { - if ( ! -e $out ) { - print "'$out' is missing.\n" - if $Verbose; - $ok = 0; - last; - } - if ( -M $out > $maxtime ) { - print "'$out' is too old.\n" - if $Verbose; - $ok = 0; - last; - } } - if ($ok) { - print "Files seem to be ok, not bothering to rebuild.\n"; - exit(0); + elsif ($arg eq '-P' && defined ($pod_directory = shift)) { + -d $pod_directory or croak "Directory '$pod_directory' doesn't exist"; + } + elsif ($arg eq '-maketest' || ($arg eq '-T' && defined ($t_path = shift))) + { + $make_test_script = 1; } - print "Must rebuild tables.\n" - if $Verbose; -} else { - if ($Verbose) { - print "Not checking filelist.\n"; + elsif ($arg eq '-makelist') { + $make_list = 1; } - if ($UseDir) { - chdir $UseDir or die "Failed to chdir to '$UseDir':$!"; + elsif ($arg eq '-C' && defined ($use_directory = shift)) { + -d $use_directory or croak "Unknown directory '$use_directory'"; + } + elsif ($arg eq '-L') { + + # Existence not tested until have chdir'd + $file_list = shift; + } + elsif ($arg eq '-globlist') { + $glob_list = 1; + } + elsif ($arg eq '-c') { + $output_range_counts = ! $output_range_counts + } + else { + my $with_c = 'with'; + $with_c .= 'out' if $output_range_counts; # Complements the state + croak <<END; +usage: $0 [-c|-p|-q|-v|-w] [-C dir] [-L filelist] [ -P pod_dir ] + [ -T test_file_path ] [-globlist] [-makelist] [-maketest] + [-check A B ] + -c : Output comments $with_c number of code points in ranges + -q : Quiet Mode: Only output serious warnings. + -p : Set verbosity level to normal plus show progress. + -v : Set Verbosity level high: Show progress and non-serious + warnings + -w : Write files regardless + -C dir : Change to this directory before proceeding. All relative paths + except those specified by the -P and -T options will be done + with respect to this directory. + -P dir : Output $pod_file file to directory 'dir'. + -T path : Create a test script as 'path'; overrides -maketest + -L filelist : Use alternate 'filelist' instead of standard one + -globlist : Take as input all non-Test *.txt files in current and sub + directories + -maketest : Make test script 'TestProp.pl' in current (or -C directory), + overrides -T + -makelist : Rewrite the file list $file_list based on current setup + -check A B : Executes $0 only if A and B are the same +END } } -foreach my $lib ('To', 'lib', - map {File::Spec->catdir("lib",$_)} - qw(gc_sc dt bc hst ea jt lb nt ccc)) { - next if -d $lib; - mkdir $lib, 0755 or die "mkdir '$lib': $!"; +# Stores the most-recently changed file. If none have changed, can skip the +# build +my $youngest = -M $0; # Do this before the chdir! + +# Change directories now, because need to read 'version' early. +if ($use_directory) { + if ($pod_directory && ! File::Spec->file_name_is_absolute($pod_directory)) { + $pod_directory = File::Spec->rel2abs($pod_directory); + } + if ($t_path && ! File::Spec->file_name_is_absolute($t_path)) { + $t_path = File::Spec->rel2abs($t_path); + } + chdir $use_directory or croak "Failed to chdir to '$use_directory':$!"; + if ($pod_directory && File::Spec->file_name_is_absolute($pod_directory)) { + $pod_directory = File::Spec->abs2rel($pod_directory); + } + if ($t_path && File::Spec->file_name_is_absolute($t_path)) { + $t_path = File::Spec->abs2rel($t_path); + } } -my $LastUnicodeCodepoint = 0x10FFFF; # As of Unicode 5.1. +# Get Unicode version into regular and v-string. This is done now because +# various tables below get populated based on it. These tables are populated +# here to be near the top of the file, and so easily seeable by those needing +# to modify things. +open my $VERSION, "<", "version" + or croak "$0: can't open required file 'version': $!\n"; +my $string_version = <$VERSION>; +close $VERSION; +chomp $string_version; +my $v_version = pack "C*", split /\./, $string_version; # v string + +# The following are the complete names of properties with property values that +# are known to not match any code points in some versions of Unicode, but that +# may change in the future so they should be matchable, hence an empty file is +# generated for them. +my @tables_that_may_be_empty = ( + 'Joining_Type=Left_Joining', + ); +push @tables_that_may_be_empty, 'Script=Common' if $v_version le v4.0.1; +push @tables_that_may_be_empty, 'Title' if $v_version lt v2.0.0; +push @tables_that_may_be_empty, 'Script=Katakana_Or_Hiragana' + if $v_version ge v4.1.0; + +# The lists below are hashes, so the key is the item in the list, and the +# value is the reason why it is in the list. This makes generation of +# documentation easier. + +my %why_suppressed; # No file generated for these. + +# Files aren't generated for empty extraneous properties. This is arguable. +# Extraneous properties generally come about because a property is no longer +# used in a newer version of Unicode. If we generated a file without code +# points, programs that used to work on that property will still execute +# without errors. It just won't ever match (or will always match, with \P{}). +# This means that the logic is now likely wrong. I (khw) think its better to +# find this out by getting an error message. Just move them to the table +# above to change this behavior +my %why_suppress_if_empty_warn_if_not = ( + + # It is the only property that has ever officially been removed from the + # Standard. The database never contained any code points for it. + 'Special_Case_Condition' => 'Obsolete', + + # Apparently never official, but there were code points in some versions of + # old-style PropList.txt + 'Non_Break' => 'Obsolete', +); -my $HEADER=<<"EOF"; -# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by $0 from e.g. UnicodeData.txt. -# Any changes made here will be lost! +# These would normally go in the warn table just above, but they were changed +# a long time before this program was written, so warnings about them are +# moot. +if ($v_version gt v3.2.0) { + push @tables_that_may_be_empty, + 'Canonical_Combining_Class=Attached_Below_Left' +} +# These are listed in the Property aliases file in 5.2, but Unihan is ignored +# unless explicitly added. +if ($v_version ge v5.2.0) { + my $unihan = 'Unihan; remove from list if using Unihan'; + foreach my $table qw ( + kAccountingNumeric + kOtherNumeric + kPrimaryNumeric + kCompatibilityVariant + kIICore + kIRG_GSource + kIRG_HSource + kIRG_JSource + kIRG_KPSource + kIRG_MSource + kIRG_KSource + kIRG_TSource + kIRG_USource + kIRG_VSource + kRSUnicode + ) + { + $why_suppress_if_empty_warn_if_not{$table} = $unihan; + } +} + +# Properties that this program ignores. +my @unimplemented_properties = ( +'Unicode_Radical_Stroke' # Remove if changing to handle this one. +); + +# There are several types of obsolete properties defined by Unicode. These +# must be hand-edited for every new Unicode release. +my %why_deprecated; # Generates a deprecated warning message if used. +my %why_stabilized; # Documentation only +my %why_obsolete; # Documentation only + +{ # Closure + my $simple = 'Perl uses the more complete version of this property'; + my $unihan = 'Unihan properties are by default not enabled in the Perl core. Instead use CPAN: Unicode::Unihan'; + + my $other_properties = 'other properties'; + my $contributory = "Used by Unicode internally for generating $other_properties and not intended to be used stand-alone"; + my $why_no_expand = "Easily computed, and yet doesn't cover the common encoding forms (UTF-16/8)", + + %why_deprecated = ( + 'Grapheme_Link' => 'Deprecated by Unicode. Use ccc=vr (Canonical_Combining_Class=Virama) instead', + 'Jamo_Short_Name' => $contributory, + 'Line_Break=Surrogate' => 'Deprecated by Unicode because surrogates should never appear in well-formed text, and therefore shouldn\'t be the basis for line breaking', + 'Other_Alphabetic' => $contributory, + 'Other_Default_Ignorable_Code_Point' => $contributory, + 'Other_Grapheme_Extend' => $contributory, + 'Other_ID_Continue' => $contributory, + 'Other_ID_Start' => $contributory, + 'Other_Lowercase' => $contributory, + 'Other_Math' => $contributory, + 'Other_Uppercase' => $contributory, + ); + + %why_suppressed = ( + # There is a lib/unicore/Decomposition.pl (used by normalize.pm) which + # contains the same information, but without the algorithmically + # determinable Hangul syllables'. This file is not published, so it's + # existence is not noted in the comment. + 'Decomposition_Mapping' => 'Accessible via Unicode::Normalize', + + 'ISO_Comment' => 'Apparently no demand for it, but can access it through Unicode::UCD::charinfo. Obsoleted, and code points for it removed in Unicode 5.2', + 'Unicode_1_Name' => "$simple, and no apparent demand for it, but can access it through Unicode::UCD::charinfo. If there is no later name for a code point, then this one is used instead in charnames", + + 'Simple_Case_Folding' => "$simple. Can access this through Unicode::UCD::casefold", + 'Simple_Lowercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo", + 'Simple_Titlecase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo", + 'Simple_Uppercase_Mapping' => "$simple. Can access this through Unicode::UCD::charinfo", + + 'Name' => "Accessible via 'use charnames;'", + 'Name_Alias' => "Accessible via 'use charnames;'", + + # These are sort of jumping the gun; deprecation is proposed for + # Unicode version 6.0, but they have never been exposed by Perl, and + # likely are soon to be deprecated, so best not to expose them. + FC_NFKC_Closure => 'Use NFKC_Casefold instead', + Expands_On_NFC => $why_no_expand, + Expands_On_NFD => $why_no_expand, + Expands_On_NFKC => $why_no_expand, + Expands_On_NFKD => $why_no_expand, + ); + + # The following are suppressed because they were made contributory or + # deprecated by Unicode before Perl ever thought about supporting them. + foreach my $property ('Jamo_Short_Name', 'Grapheme_Link') { + $why_suppressed{$property} = $why_deprecated{$property}; + } + + # Customize the message for all the 'Other_' properties + foreach my $property (keys %why_deprecated) { + next if (my $main_property = $property) !~ s/^Other_//; + $why_deprecated{$property} =~ s/$other_properties/the $main_property property (which should be used instead)/; + } +} + +if ($v_version ge 4.0.0) { + $why_stabilized{'Hyphen'} = 'Use the Line_Break property instead; see www.unicode.org/reports/tr14'; +} +if ($v_version ge 5.2.0) { + $why_obsolete{'ISO_Comment'} = 'Code points for it have been removed'; +} + +# Probably obsolete forever +if ($v_version ge v4.1.0) { + $why_suppressed{'Script=Katakana_Or_Hiragana'} = 'Obsolete. All code points previously matched by this have been moved to "Script=Common"'; +} + +# This program can create files for enumerated-like properties, such as +# 'Numeric_Type'. This file would be the same format as for a string +# property, with a mapping from code point to its value, so you could look up, +# for example, the script a code point is in. But no one so far wants this +# mapping, or they have found another way to get it since this is a new +# feature. So no file is generated except if it is in this list. +my @output_mapped_properties = split "\n", <<END; +END + +# If you are using the Unihan database, you need to add the properties that +# you want to extract from it to this table. For your convenience, the +# properties in the 5.2 PropertyAliases.txt file are listed, commented out +my @cjk_properties = split "\n", <<'END'; +#cjkAccountingNumeric; kAccountingNumeric +#cjkOtherNumeric; kOtherNumeric +#cjkPrimaryNumeric; kPrimaryNumeric +#cjkCompatibilityVariant; kCompatibilityVariant +#cjkIICore ; kIICore +#cjkIRG_GSource; kIRG_GSource +#cjkIRG_HSource; kIRG_HSource +#cjkIRG_JSource; kIRG_JSource +#cjkIRG_KPSource; kIRG_KPSource +#cjkIRG_KSource; kIRG_KSource +#cjkIRG_TSource; kIRG_TSource +#cjkIRG_USource; kIRG_USource +#cjkIRG_VSource; kIRG_VSource +#cjkRSUnicode; kRSUnicode ; Unicode_Radical_Stroke; URS +END + +# Similarly for the property values. For your convenience, the lines in the +# 5.2 PropertyAliases.txt file are listed. Just remove the first BUT NOT both +# '#' marks +my @cjk_property_values = split "\n", <<'END'; +## @missing: 0000..10FFFF; cjkAccountingNumeric; NaN +## @missing: 0000..10FFFF; cjkCompatibilityVariant; <code point> +## @missing: 0000..10FFFF; cjkIICore; <none> +## @missing: 0000..10FFFF; cjkIRG_GSource; <none> +## @missing: 0000..10FFFF; cjkIRG_HSource; <none> +## @missing: 0000..10FFFF; cjkIRG_JSource; <none> +## @missing: 0000..10FFFF; cjkIRG_KPSource; <none> +## @missing: 0000..10FFFF; cjkIRG_KSource; <none> +## @missing: 0000..10FFFF; cjkIRG_TSource; <none> +## @missing: 0000..10FFFF; cjkIRG_USource; <none> +## @missing: 0000..10FFFF; cjkIRG_VSource; <none> +## @missing: 0000..10FFFF; cjkOtherNumeric; NaN +## @missing: 0000..10FFFF; cjkPrimaryNumeric; NaN +## @missing: 0000..10FFFF; cjkRSUnicode; <none> +END + +# The input files don't list every code point. Those not listed are to be +# defaulted to some value. Below are hard-coded what those values are for +# non-binary properties as of 5.1. Starting in 5.0, there are +# machine-parsable comment lines in the files the give the defaults; so this +# list shouldn't have to be extended. The claim is that all missing entries +# for binary properties will default to 'N'. Unicode tried to change that in +# 5.2, but the beta period produced enough protest that they backed off. +# +# The defaults for the fields that appear in UnicodeData.txt in this hash must +# be in the form that it expects. The others may be synonyms. +my $CODE_POINT = '<code point>'; +my %default_mapping = ( + Age => "Unassigned", + # Bidi_Class => Complicated; set in code + Bidi_Mirroring_Glyph => "", + Block => 'No_Block', + Canonical_Combining_Class => 0, + Case_Folding => $CODE_POINT, + Decomposition_Mapping => $CODE_POINT, + Decomposition_Type => 'None', + East_Asian_Width => "Neutral", + FC_NFKC_Closure => $CODE_POINT, + General_Category => 'Cn', + Grapheme_Cluster_Break => 'Other', + Hangul_Syllable_Type => 'NA', + ISO_Comment => "", + Jamo_Short_Name => "", + Joining_Group => "No_Joining_Group", + # Joining_Type => Complicated; set in code + kIICore => 'N', # Is converted to binary + #Line_Break => Complicated; set in code + Lowercase_Mapping => $CODE_POINT, + Name => "", + Name_Alias => "", + NFC_QC => 'Yes', + NFD_QC => 'Yes', + NFKC_QC => 'Yes', + NFKD_QC => 'Yes', + Numeric_Type => 'None', + Numeric_Value => 'NaN', + Script => ($v_version le 4.1.0) ? 'Common' : 'Unknown', + Sentence_Break => 'Other', + Simple_Case_Folding => $CODE_POINT, + Simple_Lowercase_Mapping => $CODE_POINT, + Simple_Titlecase_Mapping => $CODE_POINT, + Simple_Uppercase_Mapping => $CODE_POINT, + Titlecase_Mapping => $CODE_POINT, + Unicode_1_Name => "", + Unicode_Radical_Stroke => "", + Uppercase_Mapping => $CODE_POINT, + Word_Break => 'Other', +); + +# Below are files that Unicode furnishes, but this program ignores, and why +my %ignored_files = ( + 'CJKRadicals.txt' => 'Unihan data', + 'Index.txt' => 'An index, not actual data', + 'NamedSqProv.txt' => 'Not officially part of the Unicode standard; Append it to NamedSequences.txt if you want to process the contents.', + 'NamesList.txt' => 'Just adds commentary', + 'NormalizationCorrections.txt' => 'Data is already in other files.', + 'Props.txt' => 'Adds nothing to PropList.txt; only in very early releases', + 'ReadMe.txt' => 'Just comments', + 'README.TXT' => 'Just comments', + 'StandardizedVariants.txt' => 'Only for glyph changes, not a Unicode character property. Does not fit into current scheme where one code point is mapped', +); + +################ End of externally interesting definitions ############### + +my $HEADER=<<"EOF"; +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is machine-generated by $0 from the Unicode +# database, Version $string_version. Any changes made here will be lost! EOF my $INTERNAL_ONLY=<<"EOF"; + +# !!!!!!! INTERNAL PERL USE ONLY !!!!!!! # This file is for internal use by the Perl program only. The format and even -# name or existence of this file are subject to change without notice. Don't -# use it directly. +# the name or existence of this file are subject to change without notice. +# Don't use it directly. +EOF + +my $DEVELOPMENT_ONLY=<<"EOF"; +# !!!!!!! DEVELOPMENT USE ONLY !!!!!!! +# This file contains information artificially constrained to code points +# present in Unicode release $string_compare_versions. +# IT CANNOT BE RELIED ON. It is for use during development only and should +# not be used for production. EOF -sub force_unlink { - my $filename = shift; - return unless -e $filename; - return if CORE::unlink($filename); - # We might need write permission - chmod 0777, $filename; - CORE::unlink($filename) or die "Couldn't unlink $filename: $!\n"; +my $LAST_UNICODE_CODEPOINT_STRING = "10FFFF"; +my $LAST_UNICODE_CODEPOINT = hex $LAST_UNICODE_CODEPOINT_STRING; +my $MAX_UNICODE_CODEPOINTS = $LAST_UNICODE_CODEPOINT + 1; + +# Matches legal code point. 4-6 hex numbers, If there are 6, the first +# two must be 10; if there are 5, the first must not be a 0. Written this way +# to decrease backtracking +my $code_point_re = + qr/ \b (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b/x; + +# 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 +my $missing_defaults_prefix = + qr/^#\s+\@missing:\s+0000\.\.$LAST_UNICODE_CODEPOINT_STRING\s*;/; + +# Property types. Unicode has more types, but these are sufficient for our +# purposes. +my $UNKNOWN = -1; # initialized to illegal value +my $NON_STRING = 1; # Either binary or enum +my $BINARY = 2; +my $ENUM = 3; # Include catalog +my $STRING = 4; # Anything else: string or misc + +# Some input files have lines that give default values for code points not +# contained in the file. Sometimes these should be ignored. +my $NO_DEFAULTS = 0; # Must evaluate to false +my $NOT_IGNORED = 1; +my $IGNORED = 2; + +# Range types. Each range has a type. Most ranges are type 0, for normal, +# and will appear in the main body of the tables in the output files, but +# there are other types of ranges as well, listed below, that are specially +# handled. There are pseudo-types as well that will never be stored as a +# type, but will affect the calculation of the type. + +# 0 is for normal, non-specials +my $MULTI_CP = 1; # Sequence of more than code point +my $HANGUL_SYLLABLE = 2; +my $CP_IN_NAME = 3; # The NAME contains the code point appended to it. +my $NULL = 4; # The map is to the null string; utf8.c can't + # handle these, nor is there an accepted syntax + # for them in \p{} constructs +my $COMPUTE_NO_MULTI_CP = 5; # Pseudo-type; means that ranges that would + # otherwise be $MULTI_CP type are instead type 0 + +# process_generic_property_file() can accept certain overrides in its input. +# Each of these must begin AND end with $CMD_DELIM. +my $CMD_DELIM = "\a"; +my $REPLACE_CMD = 'replace'; # Override the Replace +my $MAP_TYPE_CMD = 'map_type'; # Override the Type + +my $NO = 0; +my $YES = 1; + +# Values for the Replace argument to add_range. +# $NO # Don't replace; add only the code points not + # already present. +my $IF_NOT_EQUIVALENT = 1; # Replace only under certain conditions; details in + # the comments at the subroutine definition. +my $UNCONDITIONALLY = 2; # Replace without conditions. +my $MULTIPLE = 4; # Don't replace, but add a duplicate record if + # already there + +# Flags to give property statuses. The phrases are to remind maintainers that +# if the flag is changed, the indefinite article referring to it in the +# documentation may need to be as well. +my $NORMAL = ""; +my $SUPPRESSED = 'z'; # The character should never actually be seen, since + # it is suppressed +my $DEPRECATED = 'D'; +my $a_bold_deprecated = "a 'B<$DEPRECATED>'"; +my $A_bold_deprecated = "A 'B<$DEPRECATED>'"; +my $DISCOURAGED = 'X'; +my $a_bold_discouraged = "an 'B<$DISCOURAGED>'"; +my $A_bold_discouraged = "An 'B<$DISCOURAGED>'"; +my $STRICTER = 'T'; +my $a_bold_stricter = "a 'B<$STRICTER>'"; +my $A_bold_stricter = "A 'B<$STRICTER>'"; +my $STABILIZED = 'S'; +my $a_bold_stabilized = "an 'B<$STABILIZED>'"; +my $A_bold_stabilized = "An 'B<$STABILIZED>'"; +my $OBSOLETE = 'O'; +my $a_bold_obsolete = "an 'B<$OBSOLETE>'"; +my $A_bold_obsolete = "An 'B<$OBSOLETE>'"; + +my %status_past_participles = ( + $DISCOURAGED => 'discouraged', + $SUPPRESSED => 'should never be generated', + $STABILIZED => 'stabilized', + $OBSOLETE => 'obsolete', + $DEPRECATED => 'deprecated' +); + +# The format of the values of the map tables: +my $BINARY_FORMAT = 'b'; +my $DECIMAL_FORMAT = 'd'; +my $FLOAT_FORMAT = 'f'; +my $INTEGER_FORMAT = 'i'; +my $HEX_FORMAT = 'x'; +my $RATIONAL_FORMAT = 'r'; +my $STRING_FORMAT = 's'; + +my %map_table_formats = ( + $BINARY_FORMAT => 'binary', + $DECIMAL_FORMAT => 'single decimal digit', + $FLOAT_FORMAT => 'floating point number', + $INTEGER_FORMAT => 'integer', + $HEX_FORMAT => 'positive hex whole number; a code point', + $RATIONAL_FORMAT => 'rational: an integer or a fraction', + $STRING_FORMAT => 'arbitrary string', +); + +# Unicode didn't put such derived files in a separate directory at first. +my $EXTRACTED_DIR = (-d 'extracted') ? 'extracted' : ""; +my $EXTRACTED = ($EXTRACTED_DIR) ? "$EXTRACTED_DIR/" : ""; +my $AUXILIARY = 'auxiliary'; + +# Hashes that will eventually go into Heavy.pl for the use of utf8_heavy.pl +my %loose_to_file_of; # loosely maps table names to their respective + # files +my %stricter_to_file_of; # same; but for stricter mapping. +my %nv_floating_to_rational; # maps numeric values floating point numbers to + # their rational equivalent +my %loose_property_name_of; # Loosely maps property names to standard form + +# These constants names and values were taken from the Unicode standard, +# version 5.1, section 3.12. They are used in conjunction with Hangul +# syllables +my $SBase = 0xAC00; +my $LBase = 0x1100; +my $VBase = 0x1161; +my $TBase = 0x11A7; +my $SCount = 11172; +my $LCount = 19; +my $VCount = 21; +my $TCount = 28; +my $NCount = $VCount * $TCount; + +# For Hangul syllables; These store the numbers from Jamo.txt in conjunction +# with the above published constants. +my %Jamo; +my %Jamo_L; # Leading consonants +my %Jamo_V; # Vowels +my %Jamo_T; # Trailing consonants + +my @unhandled_properties; # Will contain a list of properties found in + # the input that we didn't process. +my @match_properties; # Properties that have match tables, to be + # listed in the pod +my @map_properties; # Properties that get map files written +my @named_sequences; # NamedSequences.txt contents. +my %potential_files; # Generated list of all .txt files in the directory + # structure so we can warn if something is being + # ignored. +my @files_actually_output; # List of files we generated. +my @more_Names; # Some code point names are compound; this is used + # to store the extra components of them. +my $MIN_FRACTION_LENGTH = 3; # How many digits of a floating point number at + # the minimum before we consider it equivalent to a + # candidate rational +my $MAX_FLOATING_SLOP = 10 ** - $MIN_FRACTION_LENGTH; # And in floating terms + +# These store references to certain commonly used property objects +my $gc; +my $perl; +my $block; + +# Are there conflicting names because of beginning with 'In_', or 'Is_' +my $has_In_conflicts = 0; +my $has_Is_conflicts = 0; + +sub internal_file_to_platform ($) { + # Convert our file paths which have '/' separators to those of the + # platform. + + my $file = shift; + return undef unless defined $file; + + return File::Spec->join(split '/', $file); } -## -## Given a filename and a reference to an array of lines, -## write the lines to the file only if the contents have not changed. -## Filename can be given as an arrayref of directory names -## -sub WriteIfChanged($\@) -{ - my $file = shift; - my $lines = shift; +sub file_exists ($) { # platform independent '-e'. This program internally + # uses slash as a path separator. + my $file = shift; + return 0 if ! defined $file; + return -e internal_file_to_platform($file); +} - $file = File::Spec->catfile(@$file) if ref $file; +sub objaddr($) { + # Returns the address of the blessed input object. + # It doesn't check for blessedness because that would do a string eval + # every call, and the program is structured so that this is never called + # for a non-blessed object. - my $TextToWrite = join '', @$lines; - if (open IN, $file) { - local($/) = undef; - my $PreviousText = <IN>; - close IN; - if ($PreviousText eq $TextToWrite) { - print "$file unchanged.\n" if $Verbose; - return unless $AlwaysWrite; - } + no overloading; # If overloaded, numifying below won't work. + + # Numifying a ref gives its address. + return 0 + $_[0]; +} + +# Commented code below should work on Perl 5.8. +## This 'require' doesn't necessarily work in miniperl, and even if it does, +## the native perl version of it (which is what would operate under miniperl) +## is extremely slow, as it does a string eval every call. +#my $has_fast_scalar_util = $ !~ /miniperl/ +# && defined eval "require Scalar::Util"; +# +#sub objaddr($) { +# # Returns the address of the blessed input object. Uses the XS version if +# # available. It doesn't check for blessedness because that would do a +# # string eval every call, and the program is structured so that this is +# # never called for a non-blessed object. +# +# return Scalar::Util::refaddr($_[0]) if $has_fast_scalar_util; +# +# # Check at least that is a ref. +# my $pkg = ref($_[0]) or return undef; +# +# # Change to a fake package to defeat any overloaded stringify +# bless $_[0], 'main::Fake'; +# +# # Numifying a ref gives its address. +# my $addr = 0 + $_[0]; +# +# # Return to original class +# bless $_[0], $pkg; +# return $addr; +#} + +sub max ($$) { + my $a = shift; + my $b = shift; + return $a if $a >= $b; + return $b; +} + +sub min ($$) { + my $a = shift; + my $b = shift; + return $a if $a <= $b; + return $b; +} + +sub clarify_number ($) { + # This returns the input number with underscores inserted every 3 digits + # in large (5 digits or more) numbers. Input must be entirely digits, not + # checked. + + my $number = shift; + my $pos = length($number) - 3; + return $number if $pos <= 1; + while ($pos > 0) { + substr($number, $pos, 0) = '_'; + $pos -= 3; } - force_unlink ($file); - if (not open OUT, ">$file") { - die "$0: can't open $file for output: $!\n"; - } - print "$file written.\n" if $Verbose; - - print OUT $TextToWrite; - close OUT; -} - -## -## The main datastructure (a "Table") represents a set of code points that -## are part of a particular quality (that are part of \pL, \p{InGreek}, -## etc.). They are kept as ranges of code points (starting and ending of -## each range). -## -## For example, a range ASCII LETTERS would be represented as: -## [ [ 0x41 => 0x5A, 'UPPER' ], -## [ 0x61 => 0x7A, 'LOWER, ] ] -## -sub RANGE_START() { 0 } ## index into range element -sub RANGE_END() { 1 } ## index into range element -sub RANGE_NAME() { 2 } ## index into range element - -## Conceptually, these should really be folded into the 'Table' objects -my %TableInfo; -my %TableDesc; -my %FuzzyNames; -my %AliasInfo; -my %CanonicalToOrig; - -## -## Turn something like -## OLD-ITALIC -## into -## OldItalic -## -sub CanonicalName($) -{ - my $orig = shift; - my $name = lc $orig; - $name =~ s/(?<![a-z])(\w)/\u$1/g; - $name =~ s/[-_\s]+//g; - - $CanonicalToOrig{$name} = $orig if not $CanonicalToOrig{$name}; - return $name; + return $number; } -## -## Store the alias definitions for later use. -## -my %PropertyAlias; -my %PropValueAlias; - -my %PA_reverse; -my %PVA_reverse; - -sub Build_Aliases() -{ - ## - ## Most of the work with aliases doesn't occur here, - ## but rather in utf8_heavy.pl, which uses PVA.pl, +package Carp; - # Placate the warnings about used only once. (They are used again, but - # via a typeglob lookup) - %utf8::PropertyAlias = (); - %utf8::PA_reverse = (); - %utf8::PropValueAlias = (); - %utf8::PVA_reverse = (); - %utf8::PVA_abbr_map = (); +# These routines give a uniform treatment of messages in this program. They +# are placed in the Carp package to cause the stack trace to not include them, +# although an alternative would be to use another package and set @CARP_NOT +# for it. - open PA, "< PropertyAliases.txt" - or confess "Can't open PropertyAliases.txt: $!"; - while (<PA>) { - s/#.*//; - s/\s+$//; - next if /^$/; +our $Verbose = 1 if main::DEBUG; # Useful info when debugging - my ($abbrev, $name) = split /\s*;\s*/; - next if $abbrev eq "n/a"; - $PropertyAlias{$abbrev} = $name; - $PA_reverse{$name} = $abbrev; +sub my_carp { + my $message = shift || ""; + my $nofold = shift || 0; - # The %utf8::... versions use japhy's code originally from utf8_pva.pl - # However, it's moved here so that we build the tables at runtime. - tr/ _-//d for $abbrev, $name; - $utf8::PropertyAlias{lc $abbrev} = $name; - $utf8::PA_reverse{lc $name} = $abbrev; - } - close PA; + if ($message) { + $message = main::join_lines($message); + $message =~ s/^$0: *//; # Remove initial program name + $message =~ s/[.;,]+$//; # Remove certain ending punctuation + $message = "\n$0: $message;"; - open PVA, "< PropValueAliases.txt" - or confess "Can't open PropValueAliases.txt: $!"; - while (<PVA>) { - s/#.*//; - s/\s+$//; - next if /^$/; + # Fold the message with program name, semi-colon end punctuation + # (which looks good with the message that carp appends to it), and a + # hanging indent for continuation lines. + $message = main::simple_fold($message, "", 4) unless $nofold; + $message =~ s/\n$//; # Remove the trailing nl so what carp + # appends is to the same line + } - my ($prop, @data) = split /\s*;\s*/; + return $message if defined wantarray; # If a caller just wants the msg - if ($prop eq 'ccc') { - $PropValueAlias{$prop}{$data[1]} = [ @data[0,2] ]; - $PVA_reverse{$prop}{$data[2]} = [ @data[0,1] ]; - } - else { - next if $data[0] eq "n/a"; - $PropValueAlias{$prop}{$data[0]} = $data[1]; - $PVA_reverse{$prop}{$data[1]} = $data[0]; - } + carp $message; + return; +} - shift @data if $prop eq 'ccc'; - next if $data[0] eq "n/a"; +sub my_carp_bug { + # This is called when it is clear that the problem is caused by a bug in + # this program. - $data[1] =~ tr/ _-//d; - $utf8::PropValueAlias{$prop}{lc $data[0]} = $data[1]; - $utf8::PVA_reverse{$prop}{lc $data[1]} = $data[0]; + my $message = shift; + $message =~ s/^$0: *//; + $message = my_carp("Bug in $0. Please report it by running perlbug or if that is unavailable, by sending email to perbug\@perl.org:\n$message"); + carp $message; + return; +} - my $abbr_class = ($prop eq 'gc' or $prop eq 'sc') ? 'gc_sc' : $prop; - $utf8::PVA_abbr_map{$abbr_class}{lc $data[0]} = $data[0]; +sub carp_too_few_args { + if (@_ != 2) { + my_carp_bug("Wrong number of arguments: to 'carp_too_few_arguments'. No action taken."); + return; } - close PVA; - # backwards compatibility for L& -> LC - $utf8::PropValueAlias{gc}{'l&'} = $utf8::PropValueAlias{gc}{lc}; - $utf8::PVA_abbr_map{gc_sc}{'l&'} = $utf8::PVA_abbr_map{gc_sc}{lc}; + my $args_ref = shift; + my $count = shift; + my_carp_bug("Need at least $count arguments to " + . (caller 1)[3] + . ". Instead got: '" + . join ', ', @$args_ref + . "'. No action taken."); + return; } +sub carp_extra_args { + my $args_ref = shift; + my_carp_bug("Too many arguments to 'carp_extra_args': (" . join(', ', @_) . "); Extras ignored.") if @_; -## -## Associates a property ("Greek", "Lu", "Assigned",...) with a Table. -## -## Called like: -## New_Prop(In => 'Greek', $Table, Desc => 'Greek Block', Fuzzy => 1); -## -## Normally, these parameters are set when the Table is created (when the -## Table->New constructor is called), but there are times when it needs to -## be done after-the-fact...) -## -sub New_Prop($$$@) -{ - my $Type = shift; ## "Is" or "In"; - my $Name = shift; - my $Table = shift; + unless (ref $args_ref) { + my_carp_bug("Argument to 'carp_extra_args' ($args_ref) must be a ref. Not checking arguments."); + return; + } + my ($package, $file, $line) = caller; + my $subroutine = (caller 1)[3]; - ## remaining args are optional key/val - my %Args = @_; - - my $Fuzzy = delete $Args{Fuzzy}; - my $Desc = delete $Args{Desc}; # description - - $Name = CanonicalName($Name) if $Fuzzy; - - ## sanity check a few args - if (%Args or ($Type ne 'Is' and $Type ne 'In') or not ref $Table) { - confess "$0: bad args to New_Prop" - } - - if (not $TableInfo{$Type}->{$Name}) - { - $TableInfo{$Type}->{$Name} = $Table; - $TableDesc{$Type}->{$Name} = $Desc; - if ($Fuzzy) { - $FuzzyNames{$Type}->{$Name} = $Name; + my $list; + if (ref $args_ref eq 'HASH') { + foreach my $key (keys %$args_ref) { + $args_ref->{$key} = $UNDEF unless defined $args_ref->{$key}; } + $list = join ', ', each %{$args_ref}; } + elsif (ref $args_ref eq 'ARRAY') { + foreach my $arg (@$args_ref) { + $arg = $UNDEF unless defined $arg; + } + $list = join ', ', @$args_ref; + } + else { + my_carp_bug("Can't cope with ref " + . ref($args_ref) + . " . argument to 'carp_extra_args'. Not checking arguments."); + return; + } + + my_carp_bug("Unrecognized parameters in options: '$list' to $subroutine. Skipped."); + return; } +package main; + +{ # Closure + + # This program uses the inside-out method for objects, as recommended in + # "Perl Best Practices". This closure aids in generating those. There + # are two routines. setup_package() is called once per package to set + # things up, and then set_access() is called for each hash representing a + # field in the object. These routines arrange for the object to be + # properly destroyed when no longer used, and for standard accessor + # functions to be generated. If you need more complex accessors, just + # write your own and leave those accesses out of the call to set_access(). + # More details below. + + my %constructor_fields; # fields that are to be used in constructors; see + # below + + # The values of this hash will be the package names as keys to other + # hashes containing the name of each field in the package as keys, and + # references to their respective hashes as values. + my %package_fields; + + sub setup_package { + # Sets up the package, creating standard DESTROY and dump methods + # (unless already defined). The dump method is used in debugging by + # simple_dumper(). + # The optional parameters are: + # a) a reference to a hash, that gets populated by later + # set_access() calls with one of the accesses being + # 'constructor'. The caller can then refer to this, but it is + # not otherwise used by these two routines. + # b) a reference to a callback routine to call during destruction + # of the object, before any fields are actually destroyed + + my %args = @_; + my $constructor_ref = delete $args{'Constructor_Fields'}; + my $destroy_callback = delete $args{'Destroy_Callback'}; + Carp::carp_extra_args(\@_) if main::DEBUG && %args; + + my %fields; + my $package = (caller)[0]; + + $package_fields{$package} = \%fields; + $constructor_fields{$package} = $constructor_ref; + + unless ($package->can('DESTROY')) { + my $destroy_name = "${package}::DESTROY"; + no strict "refs"; + + # Use typeglob to give the anonymous subroutine the name we want + *$destroy_name = sub { + my $self = shift; + my $addr = main::objaddr($self); + + $self->$destroy_callback if $destroy_callback; + foreach my $field (keys %{$package_fields{$package}}) { + #print STDERR __LINE__, ": Destroying ", ref $self, " ", sprintf("%04X", $addr), ": ", $field, "\n"; + delete $package_fields{$package}{$field}{$addr}; + } + return; + } + } -## -## Creates a new Table object. -## -## Args are key/value pairs: -## In => Name -- Name of "In" property to be associated with -## Is => Name -- Name of "Is" property to be associated with -## Fuzzy => Boolean -- True if name can be accessed "fuzzily" -## Desc => String -- Description of the property -## -## No args are required. -## -sub Table::New -{ - my $class = shift; - my %Args = @_; + unless ($package->can('dump')) { + my $dump_name = "${package}::dump"; + no strict "refs"; + *$dump_name = sub { + my $self = shift; + return dump_inside_out($self, $package_fields{$package}, @_); + } + } + return; + } - my $Table = bless [], $class; + sub set_access { + # Arrange for the input field to be garbage collected when no longer + # needed. Also, creates standard accessor functions for the field + # based on the optional parameters-- none if none of these parameters: + # 'addable' creates an 'add_NAME()' accessor function. + # 'readable' or 'readable_array' creates a 'NAME()' accessor + # function. + # 'settable' creates a 'set_NAME()' accessor function. + # 'constructor' doesn't create an accessor function, but adds the + # field to the hash that was previously passed to + # setup_package(); + # Any of the accesses can be abbreviated down, so that 'a', 'ad', + # 'add' etc. all mean 'addable'. + # The read accessor function will work on both array and scalar + # values. If another accessor in the parameter list is 'a', the read + # access assumes an array. You can also force it to be array access + # by specifying 'readable_array' instead of 'readable' + # + # A sort-of 'protected' access can be set-up by preceding the addable, + # readable or settable with some initial portion of 'protected_' (but, + # the underscore is required), like 'p_a', 'pro_set', etc. The + # "protection" is only by convention. All that happens is that the + # accessor functions' names begin with an underscore. So instead of + # calling set_foo, the call is _set_foo. (Real protection could be + # accomplished by having a new subroutine, end_package called at the + # end of each package, and then storing the __LINE__ ranges and + # checking them on every accessor. But that is way overkill.) + + # We create anonymous subroutines as the accessors and then use + # typeglobs to assign them to the proper package and name + + my $name = shift; # Name of the field + my $field = shift; # Reference to the inside-out hash containing the + # field + + my $package = (caller)[0]; + + if (! exists $package_fields{$package}) { + croak "$0: Must call 'setup_package' before 'set_access'"; + } - my $Fuzzy = delete $Args{Fuzzy}; - my $Desc = delete $Args{Desc}; + # Stash the field so DESTROY can get it. + $package_fields{$package}{$name} = $field; - for my $Type ('Is', 'In') - { - if (my $Name = delete $Args{$Type}) { - New_Prop($Type => $Name, $Table, Desc => $Desc, Fuzzy => $Fuzzy); + # Remaining arguments are the accessors. For each... + foreach my $access (@_) { + my $access = lc $access; + + my $protected = ""; + + # Match the input as far as it goes. + if ($access =~ /^(p[^_]*)_/) { + $protected = $1; + if (substr('protected_', 0, length $protected) + eq $protected) + { + + # Add 1 for the underscore not included in $protected + $access = substr($access, length($protected) + 1); + $protected = '_'; + } + else { + $protected = ""; + } + } + + if (substr('addable', 0, length $access) eq $access) { + my $subname = "${package}::${protected}add_$name"; + no strict "refs"; + + # add_ accessor. Don't add if already there, which we + # determine using 'eq' for scalars and '==' otherwise. + *$subname = sub { + use strict "refs"; + return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2; + my $self = shift; + my $value = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + if (ref $value) { + return if grep { $value == $_ } + @{$field->{main::objaddr $self}}; + } + else { + return if grep { $value eq $_ } + @{$field->{main::objaddr $self}}; + } + push @{$field->{main::objaddr $self}}, $value; + return; + } + } + elsif (substr('constructor', 0, length $access) eq $access) { + if ($protected) { + Carp::my_carp_bug("Can't set-up 'protected' constructors") + } + else { + $constructor_fields{$package}{$name} = $field; + } + } + elsif (substr('readable_array', 0, length $access) eq $access) { + + # Here has read access. If one of the other parameters for + # access is array, or this one specifies array (by being more + # than just 'readable_'), then create a subroutine that + # assumes the data is an array. Otherwise just a scalar + my $subname = "${package}::${protected}$name"; + if (grep { /^a/i } @_ + or length($access) > length('readable_')) + { + no strict "refs"; + *$subname = sub { + use strict "refs"; + Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1; + my $addr = main::objaddr $_[0]; + if (ref $field->{$addr} ne 'ARRAY') { + my $type = ref $field->{$addr}; + $type = 'scalar' unless $type; + Carp::my_carp_bug("Trying to read $name as an array when it is a $type. Big problems."); + return; + } + return scalar @{$field->{$addr}} unless wantarray; + + # Make a copy; had problems with caller modifying the + # original otherwise + my @return = @{$field->{$addr}}; + return @return; + } + } + else { + + # Here not an array value, a simpler function. + no strict "refs"; + *$subname = sub { + use strict "refs"; + Carp::carp_extra_args(\@_) if main::DEBUG && @_ > 1; + return $field->{main::objaddr $_[0]}; + } + } + } + elsif (substr('settable', 0, length $access) eq $access) { + my $subname = "${package}::${protected}set_$name"; + no strict "refs"; + *$subname = sub { + use strict "refs"; + if (main::DEBUG) { + return Carp::carp_too_few_args(\@_, 2) if @_ < 2; + Carp::carp_extra_args(\@_) if @_ > 2; + } + # $self is $_[0]; $value is $_[1] + $field->{main::objaddr $_[0]} = $_[1]; + return; + } + } + else { + Carp::my_carp_bug("Unknown accessor type $access. No accessor set."); + } } + return; } - - ## shouldn't have any left over - if (%Args) { - confess "$0: bad args to Table->New" - } - - return $Table; -} - - -## -## Returns the maximum code point currently in the table. -## -sub Table::Max -{ - my $last = $_[0]->[-1]; ## last code point - confess "oops" unless $last; ## must have code points to have a max - return $last->[RANGE_END]; -} - -## -## Replaces the codepoints in the Table with those in the Table given -## as an arg. (NOTE: this is not a "deep copy"). -## -sub Table::Replace($$) -{ - my $Table = shift; #self - my $New = shift; - - @$Table = @$New; -} - -## -## Given a new code point, make the last range of the Table extend to -## include the new (and all intervening) code points. -## -## Takes the time to make sure that the extension is valid. -## -sub Table::Extend -{ - my $Table = shift; #self - my $codepoint = shift; - - my $PrevMax = $Table->Max; - - confess "oops ($codepoint <= $PrevMax)" if $codepoint <= $PrevMax; - - $Table->ExtendNoCheck($codepoint); -} - - -## -## Given a new code point, make the last range of the Table extend to -## include the new (and all intervening) code points. -## -## Does NOT check that the extension is valid. Assumes that the caller -## has already made this check. -## -sub Table::ExtendNoCheck -{ - ## Optmized adding: Assumes $Table and $codepoint as parms - $_[0]->[-1]->[RANGE_END] = $_[1]; -} - -## -## Given a code point range start and end (and optional name), blindly -## append them to the list of ranges for the Table. -## -## NOTE: Code points must be added in strictly ascending numeric order. -## -sub Table::RawAppendRange -{ - my $Table = shift; #self - my $start = shift; - my $end = shift; - my $name = shift; - $name = "" if not defined $name; ## warning: $name can be "0" - - push @$Table, [ $start, # RANGE_START - $end, # RANGE_END - $name ]; # RANGE_NAME -} - -## -## Given a code point (and optional name), add it to the Table. -## -## NOTE: Code points must be added in strictly ascending numeric order. -## -sub Table::Append -{ - my $Table = shift; #self - my $codepoint = shift; - my $name = shift; - $name = "" if not defined $name; ## warning: $name can be "0" - - ## - ## If we've already got a range working, and this code point is the next - ## one in line, and if the name is the same, just extend the current range. - ## - my $last = $Table->[-1]; - if ($last - and - $last->[RANGE_END] == $codepoint - 1 - and - $last->[RANGE_NAME] eq $name) - { - $Table->ExtendNoCheck($codepoint); - } - else - { - $Table->RawAppendRange($codepoint, $codepoint, $name); - } -} - -## -## Given a code point range starting value and ending value (and name), -## Add the range to the Table. -## -## NOTE: Code points must be added in strictly ascending numeric order. -## -sub Table::AppendRange -{ - my $Table = shift; #self - my $start = shift; - my $end = shift; - my $name = shift; - $name = "" if not defined $name; ## warning: $name can be "0" - - $Table->Append($start, $name); - $Table->Extend($end) if $end > $start; -} - -## -## Return a new Table that represents all code points not in the Table. -## -sub Table::Invert -{ - my $Table = shift; #self - - my $New = Table->New(); - my $max = -1; - for my $range (@$Table) - { - my $start = $range->[RANGE_START]; - my $end = $range->[RANGE_END]; - if ($start-1 >= $max+1) { - $New->AppendRange($max+1, $start-1, ""); - } - $max = $end; - } - if ($max+1 < $LastUnicodeCodepoint) { - $New->AppendRange($max+1, $LastUnicodeCodepoint); - } - return $New; -} - -## -## Merges any number of other tables with $self, returning the new table. -## (existing tables are not modified) -## -## -## Args may be Tables, or individual code points (as integers). -## -## Can be called as either a constructor or a method. -## -sub Table::Merge -{ - shift(@_) if not ref $_[0]; ## if called as a constructor, lose the class - my @Tables = @_; - - ## Accumulate all records from all tables - my @Records; - for my $Arg (@Tables) - { - if (ref $Arg) { - ## arg is a table -- get its ranges - push @Records, @$Arg; - } else { - ## arg is a codepoint, make a range - push @Records, [ $Arg, $Arg ] +} + +package Input_file; + +# All input files use this object, which stores various attributes about them, +# and provides for convenient, uniform handling. The run method wraps the +# processing. It handles all the bookkeeping of opening, reading, and closing +# the file, returning only significant input lines. +# +# Each object gets a handler which processes the body of the file, and is +# called by run(). Most should use the generic, default handler, which has +# code scrubbed to handle things you might not expect. A handler should +# basically be a while(next_line()) {...} loop. +# +# You can also set up handlers to +# 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 +# 3) call upon EOF before the main handler exits its loop +# 4) call at the end for post processing +# +# $_ is used to store the input line, and is to be filtered by the +# 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. None of the other +# handlers are stackable, but could easily be changed to be so. +# +# Most of the handlers can call insert_lines() or insert_adjusted_lines() +# which insert the parameters as lines to be processed before the next input +# file line is read. This allows the EOF handler to flush buffers, for +# example. The difference between the two routines is that the lines inserted +# by insert_lines() are subjected to the each_line_handler()s. (So if you +# called it from such a handler, you would get infinite recursion.) Lines +# inserted by insert_adjusted_lines() go directly to the main handler without +# any adjustments. If the post-processing handler calls any of these, there +# will be no effect. Some error checking for these conditions could be added, +# but it hasn't been done. +# +# carp_bad_line() should be called to warn of bad input lines, which clears $_ +# to prevent further processing of the line. This routine will output the +# message as a warning once, and then keep a count of the lines that have the +# same message, and output that count at the end of the file's processing. +# This keeps the number of messages down to a manageable amount. +# +# get_missings() should be called to retrieve any @missing input lines. +# Messages will be raised if this isn't done if the options aren't to ignore +# missings. + +sub trace { return main::trace(@_); } + + +{ # Closure + # Keep track of fields that are to be put into the constructor. + my %constructor_fields; + + main::setup_package(Constructor_Fields => \%constructor_fields); + + my %file; # Input file name, required + main::set_access('file', \%file, qw{ c r }); + + my %first_released; # Unicode version file was first released in, required + main::set_access('first_released', \%first_released, qw{ c r }); + + my %handler; # Subroutine to process the input file, defaults to + # 'process_generic_property_file' + main::set_access('handler', \%handler, qw{ c }); + + my %property; + # name of property this file is for. defaults to none, meaning not + # applicable, or is otherwise determinable, for example, from each line. + main::set_access('property', \%property, qw{ c }); + + my %optional; + # If this is true, the file is optional. If not present, no warning is + # output. If it is present, the string given by this parameter is + # evaluated, and if false the file is not processed. + main::set_access('optional', \%optional, 'c', 'r'); + + my %non_skip; + # This is used for debugging, to skip processing of all but a few input + # files. Add 'non_skip => 1' to the constructor for those files you want + # processed when you set the $debug_skip global. + main::set_access('non_skip', \%non_skip, 'c'); + + my %each_line_handler; + # list of subroutines to look at and filter each non-comment line in the + # file. defaults to none. The subroutines are called in order, each is + # to adjust $_ for the next one, and the final one adjusts it for + # 'handler' + main::set_access('each_line_handler', \%each_line_handler, 'c'); + + my %has_missings_defaults; + # ? Are there lines in the file giving default values for code points + # missing from it?. Defaults to NO_DEFAULTS. Otherwise NOT_IGNORED is + # the norm, but IGNORED means it has such lines, but the handler doesn't + # use them. Having these three states allows us to catch changes to the + # UCD that this program should track + main::set_access('has_missings_defaults', + \%has_missings_defaults, qw{ c r }); + + my %pre_handler; + # Subroutine to call before doing anything else in the file. If undef, no + # such handler is called. + main::set_access('pre_handler', \%pre_handler, qw{ c }); + + my %eof_handler; + # Subroutine to call upon getting an EOF on the input file, but before + # that is returned to the main handler. This is to allow buffers to be + # flushed. The handler is expected to call insert_lines() or + # insert_adjusted() with the buffered material + main::set_access('eof_handler', \%eof_handler, qw{ c r }); + + my %post_handler; + # Subroutine to call after all the lines of the file are read in and + # processed. If undef, no such handler is called. + main::set_access('post_handler', \%post_handler, qw{ c }); + + my %progress_message; + # Message to print to display progress in lieu of the standard one + main::set_access('progress_message', \%progress_message, qw{ c }); + + my %handle; + # cache open file handle, internal. Is undef if file hasn't been + # processed at all, empty if has; + main::set_access('handle', \%handle); + + my %added_lines; + # cache of lines added virtually to the file, internal + main::set_access('added_lines', \%added_lines); + + my %errors; + # cache of errors found, internal + main::set_access('errors', \%errors); + + my %missings; + # storage of '@missing' defaults lines + main::set_access('missings', \%missings); + + sub new { + my $class = shift; + + my $self = bless \do{ my $anonymous_scalar }, $class; + my $addr = main::objaddr($self); + + # Set defaults + $handler{$addr} = \&main::process_generic_property_file; + $non_skip{$addr} = 0; + $has_missings_defaults{$addr} = $NO_DEFAULTS; + $handle{$addr} = undef; + $added_lines{$addr} = [ ]; + $each_line_handler{$addr} = [ ]; + $errors{$addr} = { }; + $missings{$addr} = [ ]; + + # Two positional parameters. + $file{$addr} = main::internal_file_to_platform(shift); + $first_released{$addr} = shift; + + # The rest of the arguments are key => value pairs + # %constructor_fields has been set up earlier to list all possible + # ones. Either set or push, depending on how the default has been set + # up just above. + my %args = @_; + foreach my $key (keys %args) { + my $argument = $args{$key}; + + # Note that the fields are the lower case of the constructor keys + my $hash = $constructor_fields{lc $key}; + if (! defined $hash) { + Carp::my_carp_bug("Unrecognized parameters '$key => $argument' to new() for $self. Skipped"); + next; + } + if (ref $hash->{$addr} eq 'ARRAY') { + if (ref $argument eq 'ARRAY') { + foreach my $argument (@{$argument}) { + next if ! defined $argument; + push @{$hash->{$addr}}, $argument; + } + } + else { + push @{$hash->{$addr}}, $argument if defined $argument; + } + } + else { + $hash->{$addr} = $argument; + } + delete $args{$key}; + }; + + # If the file has a property for it, it means that the property is not + # listed in the file's entries. So add a handler to the list of line + # handlers to insert the property name into the lines, to provide a + # uniform interface to the final processing subroutine. + # the final code doesn't have to worry about that. + if ($property{$addr}) { + push @{$each_line_handler{$addr}}, \&_insert_property_into_line; + } + + if ($non_skip{$addr} && ! $debug_skip && $verbosity) { + print "Warning: " . __PACKAGE__ . " constructor for $file{$addr} has useless 'non_skip' in it\n"; } + + return $self; } - ## sort by range start, with longer ranges coming first. - my ($first, @Rest) = sort { - ($a->[RANGE_START] <=> $b->[RANGE_START]) - or - ($b->[RANGE_END] <=> $b->[RANGE_END]) - } @Records; - my $New = Table->New(); + use overload + fallback => 0, + qw("") => "_operator_stringify", + "." => \&main::_operator_dot, + ; - ## Ensuring the first range is there makes the subsequent loop easier - $New->AppendRange($first->[RANGE_START], - $first->[RANGE_END]); + sub _operator_stringify { + my $self = shift; - ## Fold in records so long as they add new information. - for my $set (@Rest) - { - my $start = $set->[RANGE_START]; - my $end = $set->[RANGE_END]; - if ($start > $New->Max) { - $New->AppendRange($start, $end); - } elsif ($end > $New->Max) { - $New->ExtendNoCheck($end); + return __PACKAGE__ . " object for " . $self->file; + } + + # flag to make sure extracted files are processed early + my $seen_non_extracted_non_age = 0; + + sub run { + # Process the input object $self. This opens and closes the file and + # calls all the handlers for it. Currently, this can only be called + # once per file, as it destroy's the EOF handler + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + my $file = $file{$addr}; + + # Don't process if not expecting this file (because released later + # than this Unicode version), and isn't there. This means if someone + # copies it into an earlier version's directory, we will go ahead and + # process it. + return if $first_released{$addr} gt $v_version && ! -e $file; + + # If in debugging mode and this file doesn't have the non-skip + # flag set, and isn't one of the critical files, skip it. + if ($debug_skip + && $first_released{$addr} ne v0 + && ! $non_skip{$addr}) + { + print "Skipping $file in debugging\n" if $verbosity; + return; + } + + # File could be optional + if ($optional{$addr}){ + return unless -e $file; + my $result = eval $optional{$addr}; + if (! defined $result) { + Carp::my_carp_bug("Got '$@' when tried to eval $optional{$addr}. $file Skipped."); + return; + } + if (! $result) { + if ($verbosity) { + print STDERR "Skipping processing input file '$file' because '$optional{$addr}' is not true\n"; + } + return; + } + } + + if (! defined $file || ! -e $file) { + + # If the file doesn't exist, see if have internal data for it + # (based on first_released being 0). + if ($first_released{$addr} eq v0) { + $handle{$addr} = 'pretend_is_open'; + } + else { + if (! $optional{$addr} # File could be optional + && $v_version ge $first_released{$addr}) + { + print STDERR "Skipping processing input file '$file' because not found\n" if $v_version ge $first_released{$addr}; + } + return; + } + } + else { + + # Here, the file exists + if ($seen_non_extracted_non_age) { + if ($file =~ /$EXTRACTED/) { + Carp::my_carp_bug(join_lines(<<END +$file should be processed just after the 'Prop..Alias' files, and before +anything not in the $EXTRACTED_DIR directory. Proceeding, but the results may +have subtle problems +END + )); + } + } + elsif ($EXTRACTED_DIR + && $first_released{$addr} ne v0 + && $file !~ /$EXTRACTED/ + && $file ne 'DAge.txt') + { + # We don't set this (by the 'if' above) if we have no + # extracted directory, so if running on an early version, + # this test won't work. Not worth worrying about. + $seen_non_extracted_non_age = 1; + } + + # And mark the file as having being processed, and warn if it + # isn't a file we are expecting. As we process the files, + # they are deleted from the hash, so any that remain at the + # end of the program are files that we didn't process. + Carp::my_carp("Was not expecting '$file'.") if + ! delete $potential_files{File::Spec->rel2abs($file)} + && ! defined $handle{$addr}; + + # Open the file, converting the slashes used in this program + # into the proper form for the OS + my $file_handle; + if (not open $file_handle, "<", $file) { + Carp::my_carp("Can't open $file. Skipping: $!"); + return 0; + } + $handle{$addr} = $file_handle; # Cache the open file handle + } + + if ($verbosity >= $PROGRESS) { + if ($progress_message{$addr}) { + print "$progress_message{$addr}\n"; + } + else { + # If using a virtual file, say so. + print "Processing ", (-e $file) + ? $file + : "substitute $file", + "\n"; + } + } + + + # Call any special handler for before the file. + &{$pre_handler{$addr}}($self) if $pre_handler{$addr}; + + # Then the main handler + &{$handler{$addr}}($self); + + # Then any special post-file handler. + &{$post_handler{$addr}}($self) if $post_handler{$addr}; + + # If any errors have been accumulated, output the counts (as the first + # error message in each class was output when it was encountered). + if ($errors{$addr}) { + my $total = 0; + my $types = 0; + foreach my $error (keys %{$errors{$addr}}) { + $total += $errors{$addr}->{$error}; + delete $errors{$addr}->{$error}; + $types++; + } + if ($total > 1) { + my $message + = "A total of $total lines had errors in $file. "; + + $message .= ($types == 1) + ? '(Only the first one was displayed.)' + : '(Only the first of each type was displayed.)'; + Carp::my_carp($message); + } + } + + if (@{$missings{$addr}}) { + Carp::my_carp_bug("Handler for $file didn't look at all the \@missing lines. Generated tables likely are wrong"); } + + # If a real file handle, close it. + close $handle{$addr} or Carp::my_carp("Can't close $file: $!") if + ref $handle{$addr}; + $handle{$addr} = ""; # Uses empty to indicate that has already seen + # the file, as opposed to undef + return; } - return $New; -} + sub next_line { + # Sets $_ to be the next logical input line, if any. Returns non-zero + # if such a line exists. 'logical' means that any lines that have + # been added via insert_lines() will be returned in $_ before the file + # is read again. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + # Here the file is open (or if the handle is not a ref, is an open + # 'virtual' file). Get the next line; any inserted lines get priority + # over the file itself. + my $adjusted; + + LINE: + while (1) { # Loop until find non-comment, non-empty line + #local $to_trace = 1 if main::DEBUG; + my $inserted_ref = shift @{$added_lines{$addr}}; + if (defined $inserted_ref) { + ($adjusted, $_) = @{$inserted_ref}; + trace $adjusted, $_ if main::DEBUG && $to_trace; + return 1 if $adjusted; + } + else { + last if ! ref $handle{$addr}; # Don't read unless is real file + last if ! defined ($_ = readline $handle{$addr}); + } + chomp; + trace $_ if main::DEBUG && $to_trace; + + # See if this line is the comment line that defines what property + # value that code points that are not listed in the file should + # have. The format or existence of these lines is not guaranteed + # by Unicode since they are comments, but the documentation says + # that this was added for machine-readability, so probably won't + # change. This works starting in Unicode Version 5.0. They look + # like: + # + # @missing: 0000..10FFFF; Not_Reordered + # @missing: 0000..10FFFF; Decomposition_Mapping; <code point> + # @missing: 0000..10FFFF; ; NaN + # + # Save the line for a later get_missings() call. + if (/$missing_defaults_prefix/) { + if ($has_missings_defaults{$addr} == $NO_DEFAULTS) { + $self->carp_bad_line("Unexpected \@missing line. Assuming no missing entries"); + } + elsif ($has_missings_defaults{$addr} == $NOT_IGNORED) { + my @defaults = split /\s* ; \s*/x, $_; + + # The first field is the @missing, which ends in a + # semi-colon, so can safely shift. + shift @defaults; + + # Some of these lines may have empty field placeholders + # which get in the way. An example is: + # @missing: 0000..10FFFF; ; NaN + # Remove them. Process starting from the top so the + # splice doesn't affect things still to be looked at. + for (my $i = @defaults - 1; $i >= 0; $i--) { + next if $defaults[$i] ne ""; + splice @defaults, $i, 1; + } -## -## Given a filename, write a representation of the Table to a file. -## May have an optional comment as a 2nd arg. -## Filename may actually be an arrayref of directories -## -sub Table::Write -{ - my $Table = shift; #self - my $filename = shift; - my $comment = shift; + # What's left should be just the property (maybe) and the + # default. Having only one element means it doesn't have + # the property. + my $default; + my $property; + if (@defaults >= 1) { + if (@defaults == 1) { + $default = $defaults[0]; + } + else { + $property = $defaults[0]; + $default = $defaults[1]; + } + } - my @OUT = $HEADER; + if (@defaults < 1 + || @defaults > 2 + || ($default =~ /^</ + && $default !~ /^<code *point>$/i + && $default !~ /^<none>$/i)) + { + $self->carp_bad_line("Unrecognized \@missing line: $_. Assuming no missing entries"); + } + else { + + # If the property is missing from the line, it should + # be the one for the whole file + $property = $property{$addr} if ! defined $property; + + # Change <none> to the null string, which is what it + # really means. If the default is the code point + # itself, set it to <code point>, which is what + # Unicode uses (but sometimes they've forgotten the + # space) + if ($default =~ /^<none>$/i) { + $default = ""; + } + elsif ($default =~ /^<code *point>$/i) { + $default = $CODE_POINT; + } + + # Store them as a sub-arrays with both components. + push @{$missings{$addr}}, [ $default, $property ]; + } + } - # files in subdirectories are internal-use-only - push @OUT, $INTERNAL_ONLY if ref $filename; + # There is nothing for the caller to process on this comment + # line. + next; + } + + # Remove comments and trailing space, and skip this line if the + # result is empty + s/#.*//; + s/\s+$//; + next if /^$/; + + # Call any handlers for this line, and skip further processing of + # the line if the handler sets the line to null. + foreach my $sub_ref (@{$each_line_handler{$addr}}) { + &{$sub_ref}($self); + next LINE if /^$/; + } + + # Here the line is ok. return success. + return 1; + } # End of looping through lines. + + # If there is an EOF handler, call it (only once) and if it generates + # more lines to process go back in the loop to handle them. + if ($eof_handler{$addr}) { + &{$eof_handler{$addr}}($self); + $eof_handler{$addr} = ""; # Currently only get one shot at it. + goto LINE if $added_lines{$addr}; + } + + # Return failure -- no more lines. + return 0; - if (defined $comment) { - $comment =~ s/\s+\Z//; - $comment =~ s/^/# /gm; - push @OUT, "#\n$comment\n#\n"; } - push @OUT, "return <<'END';\n"; - for my $set (@$Table) - { - my $start = $set->[RANGE_START]; - my $end = $set->[RANGE_END]; - my $name = $set->[RANGE_NAME]; +# Not currently used, not fully tested. +# sub peek { +# # Non-destructive look-ahead one non-adjusted, non-comment, non-blank +# # record. Not callable from an each_line_handler(), nor does it call +# # an each_line_handler() on the line. +# +# my $self = shift; +# my $addr = main::objaddr $self; +# +# foreach my $inserted_ref (@{$added_lines{$addr}}) { +# my ($adjusted, $line) = @{$inserted_ref}; +# next if $adjusted; +# +# # Remove comments and trailing space, and return a non-empty +# # resulting line +# $line =~ s/#.*//; +# $line =~ s/\s+$//; +# return $line if $line ne ""; +# } +# +# return if ! ref $handle{$addr}; # Don't read unless is real file +# while (1) { # Loop until find non-comment, non-empty line +# local $to_trace = 1 if main::DEBUG; +# trace $_ if main::DEBUG && $to_trace; +# return if ! defined (my $line = readline $handle{$addr}); +# chomp $line; +# push @{$added_lines{$addr}}, [ 0, $line ]; +# +# $line =~ s/#.*//; +# $line =~ s/\s+$//; +# return $line if $line ne ""; +# } +# +# return; +# } + + + sub insert_lines { + # Lines can be inserted so that it looks like they were in the input + # file at the place it was when this routine is called. See also + # insert_adjusted_lines(). Lines inserted via this routine go through + # any each_line_handler() + + my $self = shift; + + # Each inserted line is an array, with the first element being 0 to + # indicate that this line hasn't been adjusted, and needs to be + # processed. + push @{$added_lines{main::objaddr $self}}, map { [ 0, $_ ] } @_; + return; + } + + sub insert_adjusted_lines { + # Lines can be inserted so that it looks like they were in the input + # file at the place it was when this routine is called. See also + # insert_lines(). Lines inserted via this routine are already fully + # adjusted, ready to be processed; each_line_handler()s handlers will + # not be called. This means this is not a completely general + # facility, as only the last each_line_handler on the stack should + # call this. It could be made more general, by passing to each of the + # line_handlers their position on the stack, which they would pass on + # to this routine, and that would replace the boolean first element in + # the anonymous array pushed here, so that the next_line routine could + # use that to call only those handlers whose index is after it on the + # stack. But this is overkill for what is needed now. + + my $self = shift; + trace $_[0] if main::DEBUG && $to_trace; + + # Each inserted line is an array, with the first element being 1 to + # indicate that this line has been adjusted + push @{$added_lines{main::objaddr $self}}, map { [ 1, $_ ] } @_; + return; + } + + sub get_missings { + # Returns the stored up @missings lines' values, and clears the list. + # The values are in an array, consisting of the default in the first + # element, and the property in the 2nd. However, since these lines + # can be stacked up, the return is an array of all these arrays. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + # If not accepting a list return, just return the first one. + return shift @{$missings{$addr}} unless wantarray; + + my @return = @{$missings{$addr}}; + undef @{$missings{$addr}}; + return @return; + } + + sub _insert_property_into_line { + # Add a property field to $_, if this file requires it. + + my $property = $property{main::objaddr shift}; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + $_ =~ s/(;|$)/; $property$1/; + return; + } + + sub carp_bad_line { + # Output consistent error messages, using either a generic one, or the + # one given by the optional parameter. To avoid gazillions of the + # same message in case the syntax of a file is way off, this routine + # only outputs the first instance of each message, incrementing a + # count so the totals can be output at the end of the file. + + my $self = shift; + my $message = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + $message = 'Unexpected line' unless $message; + + # No trailing punctuation so as to fit with our addenda. + $message =~ s/[.:;,]$//; - if ($start == $end) { - push @OUT, sprintf "%04X\t\t%s\n", $start, $name; - } else { - push @OUT, sprintf "%04X\t%04X\t%s\n", $start, $end, $name; + # If haven't seen this exact message before, output it now. Otherwise + # increment the count of how many times it has occurred + unless ($errors{$addr}->{$message}) { + Carp::my_carp("$message in '$_' in " + . $file{main::objaddr $self} + . " at line $.. Skipping this line;"); + $errors{$addr}->{$message} = 1; } + else { + $errors{$addr}->{$message}++; + } + + # Clear the line to prevent any further (meaningful) processing of it. + $_ = ""; + + return; } +} # End closure - push @OUT, "END\n"; +package Multi_Default; - WriteIfChanged($filename, @OUT); -} +# Certain properties in early versions of Unicode had more than one possible +# default for code points missing from the files. In these cases, one +# default applies to everything left over after all the others are applied, +# and for each of the others, there is a description of which class of code +# points applies to it. This object helps implement this by storing the +# defaults, and for all but that final default, an eval string that generates +# the class that it applies to. + + +{ # Closure + + main::setup_package(); + + my %class_defaults; + # The defaults structure for the classes + main::set_access('class_defaults', \%class_defaults); + + my %other_default; + # The default that applies to everything left over. + main::set_access('other_default', \%other_default, 'r'); + + + sub new { + # The constructor is called with default => eval pairs, terminated by + # the left-over default. e.g. + # Multi_Default->new( + # 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C + # - 0x200D', + # 'R' => 'some other expression that evaluates to code points', + # . + # . + # . + # 'U')); + + my $class = shift; + + my $self = bless \do{my $anonymous_scalar}, $class; + my $addr = main::objaddr($self); + + while (@_ > 1) { + my $default = shift; + my $eval = shift; + $class_defaults{$addr}->{$default} = $eval; + } + + $other_default{$addr} = shift; + + return $self; + } + + sub get_next_defaults { + # Iterates and returns the next class of defaults. + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; -## This used only for making the test script. -## helper function -sub IsUsable($) -{ - my $code = shift; - return 0 if $code <= 0x0000; ## don't use null - return 0 if $code >= $LastUnicodeCodepoint; ## keep in range - return 0 if ($code >= 0xD800 and $code <= 0xDFFF); ## no surrogates - return 0 if ($code >= 0xFDD0 and $code <= 0xFDEF); ## utf8.c says no good - return 0 if (($code & 0xFFFF) == 0xFFFE); ## utf8.c says no good - return 0 if (($code & 0xFFFF) == 0xFFFF); ## utf8.c says no good - return 1; + return each %{$class_defaults{$addr}}; + } } -## Return a code point that's part of the table. -## Returns nothing if the table is empty (or covers only surrogates). -## This used only for making the test script. -sub Table::ValidCode -{ - my $Table = shift; #self - for my $set (@$Table) { - return $set->[RANGE_END] if IsUsable($set->[RANGE_END]); +package Alias; + +# An alias is one of the names that a table goes by. This class defines them +# including some attributes. Everything is currently setup in the +# constructor. + + +{ # Closure + + main::setup_package(); + + my %name; + main::set_access('name', \%name, 'r'); + + my %loose_match; + # Determined by the constructor code if this name should match loosely or + # not. The constructor parameters can override this, but it isn't fully + # implemented, as should have ability to override Unicode one's via + # something like a set_loose_match() + main::set_access('loose_match', \%loose_match, 'r'); + + my %make_pod_entry; + # Some aliases should not get their own entries because they are covered + # by a wild-card, and some we want to discourage use of. Binary + main::set_access('make_pod_entry', \%make_pod_entry, 'r'); + + my %status; + # Aliases have a status, like deprecated, or even suppressed (which means + # they don't appear in documentation). Enum + main::set_access('status', \%status, 'r'); + + my %externally_ok; + # Similarly, some aliases should not be considered as usable ones for + # external use, such as file names, or we don't want documentation to + # recommend them. Boolean + main::set_access('externally_ok', \%externally_ok, 'r'); + + sub new { + my $class = shift; + + my $self = bless \do { my $anonymous_scalar }, $class; + my $addr = main::objaddr($self); + + $name{$addr} = shift; + $loose_match{$addr} = shift; + $make_pod_entry{$addr} = shift; + $externally_ok{$addr} = shift; + $status{$addr} = shift; + + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # Null names are never ok externally + $externally_ok{$addr} = 0 if $name{$addr} eq ""; + + return $self; } - return (); } -## Return a code point that's not part of the table -## Returns nothing if the table covers all code points. -## This used only for making the test script. -sub Table::InvalidCode -{ - my $Table = shift; #self +package Range; - return 0x1234 if not @$Table; +# A range is the basic unit for storing code points, and is described in the +# comments at the beginning of the program. Each range has a starting code +# point; an ending code point (not less than the starting one); a value +# that applies to every code point in between the two end-points, inclusive; +# and an enum type that applies to the value. The type is for the user's +# convenience, and has no meaning here, except that a non-zero type is +# considered to not obey the normal Unicode rules for having standard forms. +# +# The same structure is used for both map and match tables, even though in the +# latter, the value (and hence type) is irrelevant and could be used as a +# comment. In map tables, the value is what all the code points in the range +# map to. Type 0 values have the standardized version of the value stored as +# well, so as to not have to recalculate it a lot. - for my $set (@$Table) - { - if (IsUsable($set->[RANGE_END] + 1)) - { - return $set->[RANGE_END] + 1; +sub trace { return main::trace(@_); } + +{ # Closure + + main::setup_package(); + + my %start; + main::set_access('start', \%start, 'r', 's'); + + my %end; + main::set_access('end', \%end, 'r', 's'); + + my %value; + main::set_access('value', \%value, 'r'); + + my %type; + main::set_access('type', \%type, 'r'); + + my %standard_form; + # The value in internal standard form. Defined only if the type is 0. + main::set_access('standard_form', \%standard_form); + + # Note that if these fields change, the dump() method should as well + + sub new { + return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3; + my $class = shift; + + my $self = bless \do { my $anonymous_scalar }, $class; + my $addr = main::objaddr($self); + + $start{$addr} = shift; + $end{$addr} = shift; + + my %args = @_; + + my $value = delete $args{'Value'}; # Can be 0 + $value = "" unless defined $value; + $value{$addr} = $value; + + $type{$addr} = delete $args{'Type'} || 0; + + Carp::carp_extra_args(\%args) if main::DEBUG && %args; + + if (! $type{$addr}) { + $standard_form{$addr} = main::standardize($value); + } + + return $self; + } + + use overload + fallback => 0, + qw("") => "_operator_stringify", + "." => \&main::_operator_dot, + ; + + sub _operator_stringify { + my $self = shift; + my $addr = main::objaddr $self; + + # Output it like '0041..0065 (value)' + my $return = sprintf("%04X", $start{$addr}) + . '..' + . sprintf("%04X", $end{$addr}); + my $value = $value{$addr}; + my $type = $type{$addr}; + $return .= ' ('; + $return .= "$value"; + $return .= ", Type=$type" if $type != 0; + $return .= ')'; + + return $return; + } + + sub standard_form { + # The standard form is the value itself if the standard form is + # undefined (that is if the value is special) + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + return $standard_form{$addr} if defined $standard_form{$addr}; + return $value{$addr}; + } + + sub dump { + # Human, not machine readable. For machine readable, comment out this + # entire routine and let the standard one take effect. + my $self = shift; + my $indent = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + my $return = $indent + . sprintf("%04X", $start{$addr}) + . '..' + . sprintf("%04X", $end{$addr}) + . " '$value{$addr}';"; + if (! defined $standard_form{$addr}) { + $return .= "(type=$type{$addr})"; + } + elsif ($standard_form{$addr} ne $value{$addr}) { + $return .= "(standard '$standard_form{$addr}')"; + } + return $return; + } +} # End closure + +package _Range_List_Base; + +# Base class for range lists. A range list is simply an ordered list of +# ranges, so that the ranges with the lowest starting numbers are first in it. +# +# When a new range is added that is adjacent to an existing range that has the +# same value and type, it merges with it to form a larger range. +# +# Ranges generally do not overlap, except that there can be multiple entries +# of single code point ranges. This is because of NameAliases.txt. +# +# In this program, there is a standard value such that if two different +# values, have the same standard value, they are considered equivalent. This +# value was chosen so that it gives correct results on Unicode data + +# There are a number of methods to manipulate range lists, and some operators +# are overloaded to handle them. + +# Because of the slowness of pure Perl objaddr() on miniperl, and measurements +# showing this package was using a lot of real time calculating that, the code +# was changed to only calculate it once per call stack. This is done by +# consistently using the package variable $addr in routines, and only calling +# objaddr() if it isn't defined, and setting that to be local, so that callees +# will have it already. It would be a good thing to change this. XXX + +sub trace { return main::trace(@_); } + +{ # Closure + + our $addr; + + main::setup_package(); + + my %ranges; + # The list of ranges + main::set_access('ranges', \%ranges, 'readable_array'); + + my %max; + # The highest code point in the list. This was originally a method, but + # actual measurements said it was used a lot. + main::set_access('max', \%max, 'r'); + + my %each_range_iterator; + # Iterator position for each_range() + main::set_access('each_range_iterator', \%each_range_iterator); + + my %owner_name_of; + # Name of parent this is attached to, if any. Solely for better error + # messages. + main::set_access('owner_name_of', \%owner_name_of, 'p_r'); + + my %_search_ranges_cache; + # A cache of the previous result from _search_ranges(), for better + # performance + main::set_access('_search_ranges_cache', \%_search_ranges_cache); + + sub new { + my $class = shift; + my %args = @_; + + # Optional initialization data for the range list. + my $initialize = delete $args{'Initialize'}; + + my $self; + + # Use _union() to initialize. _union() returns an object of this + # class, which means that it will call this constructor recursively. + # But it won't have this $initialize parameter so that it won't + # infinitely loop on this. + return _union($class, $initialize, %args) if defined $initialize; + + $self = bless \do { my $anonymous_scalar }, $class; + local $addr = main::objaddr($self); + + # Optional parent object, only for debug info. + $owner_name_of{$addr} = delete $args{'Owner'}; + $owner_name_of{$addr} = "" if ! defined $owner_name_of{$addr}; + + # Stringify, in case it is an object. + $owner_name_of{$addr} = "$owner_name_of{$addr}"; + + # This is used only for error messages, and so a colon is added + $owner_name_of{$addr} .= ": " if $owner_name_of{$addr} ne ""; + + Carp::carp_extra_args(\%args) if main::DEBUG && %args; + + # Max is initialized to a negative value that isn't adjacent to 0, + # for simpler tests + $max{$addr} = -2; + + $_search_ranges_cache{$addr} = 0; + $ranges{$addr} = []; + + return $self; + } + + use overload + fallback => 0, + qw("") => "_operator_stringify", + "." => \&main::_operator_dot, + ; + + sub _operator_stringify { + my $self = shift; + local $addr = main::objaddr($self) if !defined $addr; + + return "Range_List attached to '$owner_name_of{$addr}'" + if $owner_name_of{$addr}; + return "anonymous Range_List " . \$self; + } + + sub _union { + # Returns the union of the input code points. It can be called as + # either a constructor or a method. If called as a method, the result + # will be a new() instance of the calling object, containing the union + # of that object with the other parameter's code points; if called as + # a constructor, the first parameter gives the class the new object + # should be, and the second parameter gives the code points to go into + # it. + # In either case, there are two parameters looked at by this routine; + # any additional parameters are passed to the new() constructor. + # + # The code points can come in the form of some object that contains + # ranges, and has a conventionally named method to access them; or + # they can be an array of individual code points (as integers); or + # just a single code point. + # + # If they are ranges, this routine doesn't make any effort to preserve + # the range values of one input over the other. Therefore this base + # class should not allow _union to be called from other than + # initialization code, so as to prevent two tables from being added + # together where the range values matter. The general form of this + # routine therefore belongs in a derived class, but it was moved here + # to avoid duplication of code. The failure to overload this in this + # class keeps it safe. + # + + my $self; + my @args; # Arguments to pass to the constructor + + my $class = shift; + + # If a method call, will start the union with the object itself, and + # the class of the new object will be the same as self. + if (ref $class) { + $self = $class; + $class = ref $self; + push @args, $self; + } + + # Add the other required parameter. + push @args, shift; + # Rest of parameters are passed on to the constructor + + # Accumulate all records from both lists. + my @records; + for my $arg (@args) { + #local $to_trace = 0 if main::DEBUG; + trace "argument = $arg" if main::DEBUG && $to_trace; + if (! defined $arg) { + my $message = ""; + if (defined $self) { + $message .= $owner_name_of{main::objaddr $self}; + } + Carp::my_carp_bug($message .= "Undefined argument to _union. No union done."); + return; + } + $arg = [ $arg ] if ! ref $arg; + my $type = ref $arg; + if ($type eq 'ARRAY') { + foreach my $element (@$arg) { + push @records, Range->new($element, $element); + } + } + elsif ($arg->isa('Range')) { + push @records, $arg; + } + elsif ($arg->can('ranges')) { + push @records, $arg->ranges; + } + else { + my $message = ""; + if (defined $self) { + $message .= $owner_name_of{main::objaddr $self}; + } + Carp::my_carp_bug($message . "Cannot take the union of a $type. No union done."); + return; + } } - if (IsUsable($set->[RANGE_START] - 1)) + # Sort with the range containing the lowest ordinal first, but if + # two ranges start at the same code point, sort with the bigger range + # of the two first, because it takes fewer cycles. + @records = sort { ($a->start <=> $b->start) + or + # if b is shorter than a, b->end will be + # less than a->end, and we want to select + # a, so want to return -1 + ($b->end <=> $a->end) + } @records; + + my $new = $class->new(@_); + + # Fold in records so long as they add new information. + for my $set (@records) { + my $start = $set->start; + my $end = $set->end; + my $value = $set->value; + if ($start > $new->max) { + $new->_add_delete('+', $start, $end, $value); + } + elsif ($end > $new->max) { + $new->_add_delete('+', $new->max +1, $end, $value); + } + } + + return $new; + } + + sub range_count { # Return the number of ranges in the range list + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr($self) if ! defined $addr; + + return scalar @{$ranges{$addr}}; + } + + sub min { + # Returns the minimum code point currently in the range list, or if + # the range list is empty, 2 beyond the max possible. This is a + # method because used so rarely, that not worth saving between calls, + # and having to worry about changing it as ranges are added and + # deleted. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr($self) if ! defined $addr; + + # If the range list is empty, return a large value that isn't adjacent + # to any that could be in the range list, for simpler tests + return $LAST_UNICODE_CODEPOINT + 2 unless scalar @{$ranges{$addr}}; + return $ranges{$addr}->[0]->start; + } + + sub contains { + # Boolean: Is argument in the range list? If so returns $i such that: + # range[$i]->end < $codepoint <= range[$i+1]->end + # which is one beyond what you want; this is so that the 0th range + # doesn't return false + my $self = shift; + my $codepoint = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr $self if ! defined $addr; + + my $i = $self->_search_ranges($codepoint); + return 0 unless defined $i; + + # The search returns $i, such that + # range[$i-1]->end < $codepoint <= range[$i]->end + # So is in the table if and only iff it is at least the start position + # of range $i. + return 0 if $ranges{$addr}->[$i]->start > $codepoint; + return $i + 1; + } + + sub value_of { + # Returns the value associated with the code point, undef if none + + my $self = shift; + my $codepoint = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr $self if ! defined $addr; + + my $i = $self->contains($codepoint); + return unless $i; + + # contains() returns 1 beyond where we should look + return $ranges{$addr}->[$i-1]->value; + } + + sub _search_ranges { + # Find the range in the list which contains a code point, or where it + # should go if were to add it. That is, it returns $i, such that: + # range[$i-1]->end < $codepoint <= range[$i]->end + # Returns undef if no such $i is possible (e.g. at end of table), or + # if there is an error. + + my $self = shift; + my $code_point = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr $self if ! defined $addr; + + return if $code_point > $max{$addr}; + my $r = $ranges{$addr}; # The current list of ranges + my $range_list_size = scalar @$r; + my $i; + + use integer; # want integer division + + # Use the cached result as the starting guess for this one, because, + # an experiment on 5.1 showed that 90% of the time the cache was the + # same as the result on the next call (and 7% it was one less). + $i = $_search_ranges_cache{$addr}; + $i = 0 if $i >= $range_list_size; # Reset if no longer valid (prob. + # from an intervening deletion + #local $to_trace = 1 if main::DEBUG; + trace "previous \$i is still valid: $i" if main::DEBUG && $to_trace && $code_point <= $r->[$i]->end && ($i == 0 || $r->[$i-1]->end < $code_point); + return $i if $code_point <= $r->[$i]->end + && ($i == 0 || $r->[$i-1]->end < $code_point); + + # Here the cache doesn't yield the correct $i. Try adding 1. + if ($i < $range_list_size - 1 + && $r->[$i]->end < $code_point && + $code_point <= $r->[$i+1]->end) { - return $set->[RANGE_START] - 1; + $i++; + trace "next \$i is correct: $i" if main::DEBUG && $to_trace; + $_search_ranges_cache{$addr} = $i; + return $i; } + + # Here, adding 1 also didn't work. We do a binary search to + # find the correct position, starting with current $i + my $lower = 0; + my $upper = $range_list_size - 1; + while (1) { + trace "top of loop i=$i:", sprintf("%04X", $r->[$lower]->start), "[$lower] .. ", sprintf("%04X", $r->[$i]->start), "[$i] .. ", sprintf("%04X", $r->[$upper]->start), "[$upper]" if main::DEBUG && $to_trace; + + if ($code_point <= $r->[$i]->end) { + + # Here we have met the upper constraint. We can quit if we + # also meet the lower one. + last if $i == 0 || $r->[$i-1]->end < $code_point; + + $upper = $i; # Still too high. + + } + else { + + # Here, $r[$i]->end < $code_point, so look higher up. + $lower = $i; + } + + # Split search domain in half to try again. + my $temp = ($upper + $lower) / 2; + + # No point in continuing unless $i changes for next time + # in the loop. + if ($temp == $i) { + + # We can't reach the highest element because of the averaging. + # So if one below the upper edge, force it there and try one + # more time. + if ($i == $range_list_size - 2) { + + trace "Forcing to upper edge" if main::DEBUG && $to_trace; + $i = $range_list_size - 1; + + # Change $lower as well so if fails next time through, + # taking the average will yield the same $i, and we will + # quit with the error message just below. + $lower = $i; + next; + } + Carp::my_carp_bug("$owner_name_of{$addr}Can't find where the range ought to go. No action taken."); + return; + } + $i = $temp; + } # End of while loop + + if (main::DEBUG && $to_trace) { + trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i; + trace "i= [ $i ]", $r->[$i]; + trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < $range_list_size - 1; + } + + # Here we have found the offset. Cache it as a starting point for the + # next call. + $_search_ranges_cache{$addr} = $i; + return $i; } - return (); -} -########################################################################### -########################################################################### -########################################################################### + sub _add_delete { + # Add, replace or delete ranges to or from a list. The $type + # parameter gives which: + # '+' => insert or replace a range, returning a list of any changed + # ranges. + # '-' => delete a range, returning a list of any deleted ranges. + # + # The next three parameters give respectively the start, end, and + # value associated with the range. 'value' should be null unless the + # operation is '+'; + # + # The range list is kept sorted so that the range with the lowest + # starting position is first in the list, and generally, adjacent + # ranges with the same values are merged into single larger one (see + # exceptions below). + # + # There are more parameters, all are key => value pairs: + # Type gives the type of the value. It is only valid for '+'. + # All ranges have types; if this parameter is omitted, 0 is + # assumed. Ranges with type 0 are assumed to obey the + # Unicode rules for casing, etc; ranges with other types are + # not. Otherwise, the type is arbitrary, for the caller's + # convenience, and looked at only by this routine to keep + # adjacent ranges of different types from being merged into + # a single larger range, and when Replace => + # $IF_NOT_EQUIVALENT is specified (see just below). + # Replace determines what to do if the range list already contains + # ranges which coincide with all or portions of the input + # range. It is only valid for '+': + # => $NO means that the new value is not to replace + # any existing ones, but any empty gaps of the + # range list coinciding with the input range + # will be filled in with the new value. + # => $UNCONDITIONALLY means to replace the existing values with + # this one unconditionally. However, if the + # new and old values are identical, the + # replacement is skipped to save cycles + # => $IF_NOT_EQUIVALENT means to replace the existing values + # with this one if they are not equivalent. + # Ranges are equivalent if their types are the + # same, and they are the same string, or if + # both are type 0 ranges, if their Unicode + # standard forms are identical. In this last + # case, the routine chooses the more "modern" + # one to use. This is because some of the + # older files are formatted with values that + # are, for example, ALL CAPs, whereas the + # derived files have a more modern style, + # which looks better. By looking for this + # style when the pre-existing and replacement + # standard forms are the same, we can move to + # the modern style + # => $MULTIPLE means that if this range duplicates an + # existing one, but has a different value, + # don't replace the existing one, but insert + # this, one so that the same range can occur + # multiple times. + # => anything else is the same as => $IF_NOT_EQUIVALENT + # + # "same value" means identical for type-0 ranges, and it means having + # the same standard forms for non-type-0 ranges. + + return Carp::carp_too_few_args(\@_, 5) if main::DEBUG && @_ < 5; + + my $self = shift; + my $operation = shift; # '+' for add/replace; '-' for delete; + my $start = shift; + my $end = shift; + my $value = shift; + + my %args = @_; + + $value = "" if not defined $value; # warning: $value can be "0" + + my $replace = delete $args{'Replace'}; + $replace = $IF_NOT_EQUIVALENT unless defined $replace; + + my $type = delete $args{'Type'}; + $type = 0 unless defined $type; + + Carp::carp_extra_args(\%args) if main::DEBUG && %args; + + local $addr = main::objaddr($self) if ! defined $addr; + + if ($operation ne '+' && $operation ne '-') { + Carp::my_carp_bug("$owner_name_of{$addr}First parameter to _add_delete must be '+' or '-'. No action taken."); + return; + } + unless (defined $start && defined $end) { + Carp::my_carp_bug("$owner_name_of{$addr}Undefined start and/or end to _add_delete. No action taken."); + return; + } + unless ($end >= $start) { + Carp::my_carp_bug("$owner_name_of{$addr}End of range (" . sprintf("%04X", $end) . ") must not be before start (" . sprintf("%04X", $start) . "). No action taken."); + return; + } + #local $to_trace = 1 if main::DEBUG; + if ($operation eq '-') { + if ($replace != $IF_NOT_EQUIVALENT) { + Carp::my_carp_bug("$owner_name_of{$addr}Replace => \$IF_NOT_EQUIVALENT is required when deleting a range from a range list. Assuming Replace => \$IF_NOT_EQUIVALENT."); + $replace = $IF_NOT_EQUIVALENT; + } + if ($type) { + Carp::my_carp_bug("$owner_name_of{$addr}Type => 0 is required when deleting a range from a range list. Assuming Type => 0."); + $type = 0; + } + if ($value ne "") { + Carp::my_carp_bug("$owner_name_of{$addr}Value => \"\" is required when deleting a range from a range list. Assuming Value => \"\"."); + $value = ""; + } + } -## -## Called like: -## New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 1); -## -## The args must be in that order, although the Fuzzy pair may be omitted. -## -## This creates 'IsAll' as an alias for 'IsAny' -## -sub New_Alias($$$@) -{ - my $Type = shift; ## "Is" or "In" - my $Alias = shift; - my $SameAs = shift; # expecting "SameAs" -- just ignored - my $Name = shift; + my $r = $ranges{$addr}; # The current list of ranges + my $range_list_size = scalar @$r; # And its size + my $max = $max{$addr}; # The current high code point in + # the list of ranges + + # Do a special case requiring fewer machine cycles when the new range + # starts after the current highest point. The Unicode input data is + # structured so this is common. + if ($start > $max) { + + trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) type=$type" if main::DEBUG && $to_trace; + return if $operation eq '-'; # Deleting a non-existing range is a + # no-op + + # If the new range doesn't logically extend the current final one + # in the range list, create a new range at the end of the range + # list. (max cleverly is initialized to a negative number not + # adjacent to 0 if the range list is empty, so even adding a range + # to an empty range list starting at 0 will have this 'if' + # succeed.) + if ($start > $max + 1 # non-adjacent means can't extend. + || @{$r}[-1]->value ne $value # values differ, can't extend. + || @{$r}[-1]->type != $type # types differ, can't extend. + ) { + push @$r, Range->new($start, $end, + Value => $value, + Type => $type); + } + else { - ## remaining args are optional key/val - my %Args = @_; + # Here, the new range starts just after the current highest in + # the range list, and they have the same type and value. + # Extend the current range to incorporate the new one. + @{$r}[-1]->set_end($end); + } + + # This becomes the new maximum. + $max{$addr} = $end; + + return; + } + #local $to_trace = 0 if main::DEBUG; + + trace "$owner_name_of{$addr} $operation", sprintf("%04X", $start) . '..' . sprintf("%04X", $end) . " ($value) replace=$replace" if main::DEBUG && $to_trace; + + # Here, the input range isn't after the whole rest of the range list. + # Most likely 'splice' will be needed. The rest of the routine finds + # the needed splice parameters, and if necessary, does the splice. + # First, find the offset parameter needed by the splice function for + # the input range. Note that the input range may span multiple + # existing ones, but we'll worry about that later. For now, just find + # the beginning. If the input range is to be inserted starting in a + # position not currently in the range list, it must (obviously) come + # just after the range below it, and just before the range above it. + # Slightly less obviously, it will occupy the position currently + # occupied by the range that is to come after it. More formally, we + # are looking for the position, $i, in the array of ranges, such that: + # + # r[$i-1]->start <= r[$i-1]->end < $start < r[$i]->start <= r[$i]->end + # + # (The ordered relationships within existing ranges are also shown in + # the equation above). However, if the start of the input range is + # within an existing range, the splice offset should point to that + # existing range's position in the list; that is $i satisfies a + # somewhat different equation, namely: + # + #r[$i-1]->start <= r[$i-1]->end < r[$i]->start <= $start <= r[$i]->end + # + # More briefly, $start can come before or after r[$i]->start, and at + # this point, we don't know which it will be. However, these + # two equations share these constraints: + # + # r[$i-1]->end < $start <= r[$i]->end + # + # And that is good enough to find $i. + + my $i = $self->_search_ranges($start); + if (! defined $i) { + Carp::my_carp_bug("Searching $self for range beginning with $start unexpectedly returned undefined. Operation '$operation' not performed"); + return; + } - my $Fuzzy = delete $Args{Fuzzy}; + # The search function returns $i such that: + # + # r[$i-1]->end < $start <= r[$i]->end + # + # That means that $i points to the first range in the range list + # that could possibly be affected by this operation. We still don't + # know if the start of the input range is within r[$i], or if it + # points to empty space between r[$i-1] and r[$i]. + trace "[$i] is the beginning splice point. Existing range there is ", $r->[$i] if main::DEBUG && $to_trace; + + # Special case the insertion of data that is not to replace any + # existing data. + if ($replace == $NO) { # If $NO, has to be operation '+' + #local $to_trace = 1 if main::DEBUG; + trace "Doesn't replace" if main::DEBUG && $to_trace; + + # Here, the new range is to take effect only on those code points + # that aren't already in an existing range. This can be done by + # looking through the existing range list and finding the gaps in + # the ranges that this new range affects, and then calling this + # function recursively on each of those gaps, leaving untouched + # anything already in the list. Gather up a list of the changed + # gaps first so that changes to the internal state as new ranges + # are added won't be a problem. + my @gap_list; + + # First, if the starting point of the input range is outside an + # existing one, there is a gap from there to the beginning of the + # existing range -- add a span to fill the part that this new + # range occupies + if ($start < $r->[$i]->start) { + push @gap_list, Range->new($start, + main::min($end, + $r->[$i]->start - 1), + Type => $type); + trace "gap before $r->[$i] [$i], will add", $gap_list[-1] if main::DEBUG && $to_trace; + } - ## sanity check a few args - if (%Args or ($Type ne 'Is' and $Type ne 'In') or $SameAs ne 'SameAs') { - confess "$0: bad args to New_Alias" + # Then look through the range list for other gaps until we reach + # the highest range affected by the input one. + my $j; + for ($j = $i+1; $j < $range_list_size; $j++) { + trace "j=[$j]", $r->[$j] if main::DEBUG && $to_trace; + last if $end < $r->[$j]->start; + + # If there is a gap between when this range starts and the + # previous one ends, add a span to fill it. Note that just + # because there are two ranges doesn't mean there is a + # non-zero gap between them. It could be that they have + # different values or types + if ($r->[$j-1]->end + 1 != $r->[$j]->start) { + push @gap_list, + Range->new($r->[$j-1]->end + 1, + $r->[$j]->start - 1, + Type => $type); + trace "gap between $r->[$j-1] and $r->[$j] [$j], will add: $gap_list[-1]" if main::DEBUG && $to_trace; + } + } + + # Here, we have either found an existing range in the range list, + # beyond the area affected by the input one, or we fell off the + # end of the loop because the input range affects the whole rest + # of the range list. In either case, $j is 1 higher than the + # highest affected range. If $j == $i, it means that there are no + # affected ranges, that the entire insertion is in the gap between + # r[$i-1], and r[$i], which we already have taken care of before + # the loop. + # On the other hand, if there are affected ranges, it might be + # that there is a gap that needs filling after the final such + # range to the end of the input range + if ($r->[$j-1]->end < $end) { + push @gap_list, Range->new(main::max($start, + $r->[$j-1]->end + 1), + $end, + Type => $type); + trace "gap after $r->[$j-1], will add $gap_list[-1]" if main::DEBUG && $to_trace; + } + + # Call recursively to fill in all the gaps. + foreach my $gap (@gap_list) { + $self->_add_delete($operation, + $gap->start, + $gap->end, + $value, + Type => $type); + } + + return; + } + + # Here, we have taken care of the case where $replace is $NO, which + # means that whatever action we now take is done unconditionally. It + # still could be that this call will result in a no-op, if duplicates + # aren't allowed, and we are inserting a range that merely duplicates + # data already in the range list; or also if deleting a non-existent + # range. + # $i still points to the first potential affected range. Now find the + # highest range affected, which will determine the length parameter to + # splice. (The input range can span multiple existing ones.) While + # we are looking through the range list, see also if this is an + # insertion that will change the values of at least one of the + # affected ranges. We don't need to do this check unless this is an + # insertion of non-multiples, and also since this is a boolean, we + # don't need to do it if have already determined that it will make a + # change; just unconditionally change them. $cdm is created to be 1 + # if either of these is true. (The 'c' in the name comes from below) + my $cdm = ($operation eq '-' || $replace == $MULTIPLE); + my $j; # This will point to the highest affected range + + # For non-zero types, the standard form is the value itself; + my $standard_form = ($type) ? $value : main::standardize($value); + + for ($j = $i; $j < $range_list_size; $j++) { + trace "Looking for highest affected range; the one at $j is ", $r->[$j] if main::DEBUG && $to_trace; + + # If find a range that it doesn't overlap into, we can stop + # searching + last if $end < $r->[$j]->start; + + # Here, overlaps the range at $j. If the value's don't match, + # and this is supposedly an insertion, it becomes a change + # instead. This is what the 'c' stands for in $cdm. + if (! $cdm) { + if ($r->[$j]->standard_form ne $standard_form) { + $cdm = 1; + } + else { + + # Here, the two values are essentially the same. If the + # two are actually identical, replacing wouldn't change + # anything so skip it. + my $pre_existing = $r->[$j]->value; + if ($pre_existing ne $value) { + + # Here the new and old standardized values are the + # same, but the non-standardized values aren't. If + # replacing unconditionally, then replace + if( $replace == $UNCONDITIONALLY) { + $cdm = 1; + } + else { + + # Here, are replacing conditionally. Decide to + # replace or not based on which appears to look + # the "nicest". If one is mixed case and the + # other isn't, choose the mixed case one. + my $new_mixed = $value =~ /[A-Z]/ + && $value =~ /[a-z]/; + my $old_mixed = $pre_existing =~ /[A-Z]/ + && $pre_existing =~ /[a-z]/; + + if ($old_mixed != $new_mixed) { + $cdm = 1 if $new_mixed; + if (main::DEBUG && $to_trace) { + if ($cdm) { + trace "Replacing $pre_existing with $value"; + } + else { + trace "Retaining $pre_existing over $value"; + } + } + } + else { + + # Here casing wasn't different between the two. + # If one has hyphens or underscores and the + # other doesn't, choose the one with the + # punctuation. + my $new_punct = $value =~ /[-_]/; + my $old_punct = $pre_existing =~ /[-_]/; + + if ($old_punct != $new_punct) { + $cdm = 1 if $new_punct; + if (main::DEBUG && $to_trace) { + if ($cdm) { + trace "Replacing $pre_existing with $value"; + } + else { + trace "Retaining $pre_existing over $value"; + } + } + } # else existing one is just as "good"; + # retain it to save cycles. + } + } + } + } + } + } # End of loop looking for highest affected range. + + # Here, $j points to one beyond the highest range that this insertion + # affects (hence to beyond the range list if that range is the final + # one in the range list). + + # The splice length is all the affected ranges. Get it before + # subtracting, for efficiency, so we don't have to later add 1. + my $length = $j - $i; + + $j--; # $j now points to the highest affected range. + trace "Final affected range is $j: $r->[$j]" if main::DEBUG && $to_trace; + + # If inserting a multiple record, this is where it goes, after all the + # existing ones for this range. This implies an insertion, and no + # change to any existing ranges. Note that $j can be -1 if this new + # range doesn't actually duplicate any existing, and comes at the + # beginning of the list, in which case we can handle it like any other + # insertion, and is easier to do so. + if ($replace == $MULTIPLE && $j >= 0) { + + # This restriction could be remedied with a little extra work, but + # it won't hopefully ever be necessary + if ($r->[$j]->start != $r->[$j]->end) { + Carp::my_carp_bug("$owner_name_of{$addr}Can't cope with adding a multiple when the other range ($r->[$j]) contains more than one code point. No action taken."); + return; + } + + # Don't add an exact duplicate, as it isn't really a multiple + return if $value eq $r->[$j]->value && $type eq $r->[$j]->type; + + trace "Adding multiple record at $j+1 with $start..$end, $value" if main::DEBUG && $to_trace; + my @return = splice @$r, + $j+1, + 0, + Range->new($start, + $end, + Value => $value, + Type => $type); + if (main::DEBUG && $to_trace) { + trace "After splice:"; + trace 'j-2=[', $j-2, ']', $r->[$j-2] if $j >= 2; + trace 'j-1=[', $j-1, ']', $r->[$j-1] if $j >= 1; + trace "j =[", $j, "]", $r->[$j] if $j >= 0; + trace 'j+1=[', $j+1, ']', $r->[$j+1] if $j < @$r - 1; + trace 'j+2=[', $j+2, ']', $r->[$j+2] if $j < @$r - 2; + trace 'j+3=[', $j+3, ']', $r->[$j+3] if $j < @$r - 3; + } + return @return; + } + + # Here, have taken care of $NO and $MULTIPLE replaces. + # $j points to the highest affected range. But it can be < $i or even + # -1. These happen only if the insertion is entirely in the gap + # between r[$i-1] and r[$i]. Here's why: j < i means that the j loop + # above exited first time through with $end < $r->[$i]->start. (And + # then we subtracted one from j) This implies also that $start < + # $r->[$i]->start, but we know from above that $r->[$i-1]->end < + # $start, so the entire input range is in the gap. + if ($j < $i) { + + # Here the entire input range is in the gap before $i. + + if (main::DEBUG && $to_trace) { + if ($i) { + trace "Entire range is between $r->[$i-1] and $r->[$i]"; + } + else { + trace "Entire range is before $r->[$i]"; + } + } + return if $operation ne '+'; # Deletion of a non-existent range is + # a no-op + } + else { + + # Here the entire input range is not in the gap before $i. There + # is an affected one, and $j points to the highest such one. + + # At this point, here is the situation: + # This is not an insertion of a multiple, nor of tentative ($NO) + # data. + # $i points to the first element in the current range list that + # may be affected by this operation. In fact, we know + # that the range at $i is affected because we are in + # the else branch of this 'if' + # $j points to the highest affected range. + # In other words, + # r[$i-1]->end < $start <= r[$i]->end + # And: + # r[$i-1]->end < $start <= $end <= r[$j]->end + # + # Also: + # $cdm is a boolean which is set true if and only if this is a + # change or deletion (multiple was handled above). In + # other words, it could be renamed to be just $cd. + + # We now have enough information to decide if this call is a no-op + # or not. It is a no-op if it is a deletion of a non-existent + # range, or an insertion of already existing data. + + if (main::DEBUG && $to_trace && ! $cdm + && $i == $j + && $start >= $r->[$i]->start) + { + trace "no-op"; + } + return if ! $cdm # change or delete => not no-op + && $i == $j # more than one affected range => not no-op + + # Here, r[$i-1]->end < $start <= $end <= r[$i]->end + # Further, $start and/or $end is >= r[$i]->start + # The test below hence guarantees that + # r[$i]->start < $start <= $end <= r[$i]->end + # This means the input range is contained entirely in + # the one at $i, so is a no-op + && $start >= $r->[$i]->start; + } + + # Here, we know that some action will have to be taken. We have + # calculated the offset and length (though adjustments may be needed) + # for the splice. Now start constructing the replacement list. + my @replacement; + my $splice_start = $i; + + my $extends_below; + my $extends_above; + + # See if should extend any adjacent ranges. + if ($operation eq '-') { # Don't extend deletions + $extends_below = $extends_above = 0; + } + else { # Here, should extend any adjacent ranges. See if there are + # any. + $extends_below = ($i > 0 + # can't extend unless adjacent + && $r->[$i-1]->end == $start -1 + # can't extend unless are same standard value + && $r->[$i-1]->standard_form eq $standard_form + # can't extend unless share type + && $r->[$i-1]->type == $type); + $extends_above = ($j+1 < $range_list_size + && $r->[$j+1]->start == $end +1 + && $r->[$j+1]->standard_form eq $standard_form + && $r->[$j-1]->type == $type); + } + if ($extends_below && $extends_above) { # Adds to both + $splice_start--; # start replace at element below + $length += 2; # will replace on both sides + trace "Extends both below and above ranges" if main::DEBUG && $to_trace; + + # The result will fill in any gap, replacing both sides, and + # create one large range. + @replacement = Range->new($r->[$i-1]->start, + $r->[$j+1]->end, + Value => $value, + Type => $type); + } + else { + + # Here we know that the result won't just be the conglomeration of + # a new range with both its adjacent neighbors. But it could + # extend one of them. + + if ($extends_below) { + + # Here the new element adds to the one below, but not to the + # one above. If inserting, and only to that one range, can + # just change its ending to include the new one. + if ($length == 0 && ! $cdm) { + $r->[$i-1]->set_end($end); + trace "inserted range extends range to below so it is now $r->[$i-1]" if main::DEBUG && $to_trace; + return; + } + else { + trace "Changing inserted range to start at ", sprintf("%04X", $r->[$i-1]->start), " instead of ", sprintf("%04X", $start) if main::DEBUG && $to_trace; + $splice_start--; # start replace at element below + $length++; # will replace the element below + $start = $r->[$i-1]->start; + } + } + elsif ($extends_above) { + + # Here the new element adds to the one above, but not below. + # Mirror the code above + if ($length == 0 && ! $cdm) { + $r->[$j+1]->set_start($start); + trace "inserted range extends range to above so it is now $r->[$j+1]" if main::DEBUG && $to_trace; + return; + } + else { + trace "Changing inserted range to end at ", sprintf("%04X", $r->[$j+1]->end), " instead of ", sprintf("%04X", $end) if main::DEBUG && $to_trace; + $length++; # will replace the element above + $end = $r->[$j+1]->end; + } + } + + trace "Range at $i is $r->[$i]" if main::DEBUG && $to_trace; + + # Finally, here we know there will have to be a splice. + # If the change or delete affects only the highest portion of the + # first affected range, the range will have to be split. The + # splice will remove the whole range, but will replace it by a new + # range containing just the unaffected part. So, in this case, + # add to the replacement list just this unaffected portion. + if (! $extends_below + && $start > $r->[$i]->start && $start <= $r->[$i]->end) + { + push @replacement, + Range->new($r->[$i]->start, + $start - 1, + Value => $r->[$i]->value, + Type => $r->[$i]->type); + } + + # In the case of an insert or change, but not a delete, we have to + # put in the new stuff; this comes next. + if ($operation eq '+') { + push @replacement, Range->new($start, + $end, + Value => $value, + Type => $type); + } + + trace "Range at $j is $r->[$j]" if main::DEBUG && $to_trace && $j != $i; + #trace "$end >=", $r->[$j]->start, " && $end <", $r->[$j]->end if main::DEBUG && $to_trace; + + # And finally, if we're changing or deleting only a portion of the + # highest affected range, it must be split, as the lowest one was. + if (! $extends_above + && $j >= 0 # Remember that j can be -1 if before first + # current element + && $end >= $r->[$j]->start + && $end < $r->[$j]->end) + { + push @replacement, + Range->new($end + 1, + $r->[$j]->end, + Value => $r->[$j]->value, + Type => $r->[$j]->type); + } + } + + # And do the splice, as calculated above + if (main::DEBUG && $to_trace) { + trace "replacing $length element(s) at $i with "; + foreach my $replacement (@replacement) { + trace " $replacement"; + } + trace "Before splice:"; + trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2; + trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1; + trace "i =[", $i, "]", $r->[$i]; + trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1; + trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2; + } + + my @return = splice @$r, $splice_start, $length, @replacement; + + if (main::DEBUG && $to_trace) { + trace "After splice:"; + trace 'i-2=[', $i-2, ']', $r->[$i-2] if $i >= 2; + trace 'i-1=[', $i-1, ']', $r->[$i-1] if $i >= 1; + trace "i =[", $i, "]", $r->[$i]; + trace 'i+1=[', $i+1, ']', $r->[$i+1] if $i < @$r - 1; + trace 'i+2=[', $i+2, ']', $r->[$i+2] if $i < @$r - 2; + trace "removed @return"; + } + + # An actual deletion could have changed the maximum in the list. + # There was no deletion if the splice didn't return something, but + # otherwise recalculate it. This is done too rarely to worry about + # performance. + if ($operation eq '-' && @return) { + $max{$addr} = $r->[-1]->end; + } + return @return; } - $Alias = CanonicalName($Alias) if $Fuzzy; + sub reset_each_range { # reset the iterator for each_range(); + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr $self if ! defined $addr; + + undef $each_range_iterator{$addr}; + return; + } + + sub each_range { + # Iterate over each range in a range list. Results are undefined if + # the range list is changed during the iteration. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr($self) if ! defined $addr; + + return if $self->is_empty; + + $each_range_iterator{$addr} = -1 + if ! defined $each_range_iterator{$addr}; + $each_range_iterator{$addr}++; + return $ranges{$addr}->[$each_range_iterator{$addr}] + if $each_range_iterator{$addr} < @{$ranges{$addr}}; + undef $each_range_iterator{$addr}; + return; + } + + sub count { # Returns count of code points in range list + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr($self) if ! defined $addr; - if (not $TableInfo{$Type}->{$Name}) + my $count = 0; + foreach my $range (@{$ranges{$addr}}) { + $count += $range->end - $range->start + 1; + } + return $count; + } + + sub delete_range { # Delete a range + my $self = shift; + my $start = shift; + my $end = shift; + + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + return $self->_add_delete('-', $start, $end, ""); + } + + sub is_empty { # Returns boolean as to if a range list is empty + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr($self) if ! defined $addr; + return scalar @{$ranges{$addr}} == 0; + } + + sub hash { + # Quickly returns a scalar suitable for separating tables into + # buckets, i.e. it is a hash function of the contents of a table, so + # there are relatively few conflicts. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + local $addr = main::objaddr($self) if ! defined $addr; + + # These are quickly computable. Return looks like 'min..max;count' + return $self->min . "..$max{$addr};" . scalar @{$ranges{$addr}}; + } +} # End closure for _Range_List_Base + +package Range_List; +use base '_Range_List_Base'; + +# A Range_List is a range list for match tables; i.e. the range values are +# not significant. Thus a number of operations can be safely added to it, +# such as inversion, intersection. Note that union is also an unsafe +# operation when range values are cared about, and that method is in the base +# class, not here. But things are set up so that that method is callable only +# during initialization. Only in this derived class, is there an operation +# that combines two tables. A Range_Map can thus be used to initialize a +# Range_List, and its mappings will be in the list, but are not significant to +# this class. + +sub trace { return main::trace(@_); } + +{ # Closure + + use overload + fallback => 0, + '+' => sub { my $self = shift; + my $other = shift; + + return $self->_union($other) + }, + '&' => sub { my $self = shift; + my $other = shift; + + return $self->_intersect($other, 0); + }, + '~' => "_invert", + '-' => "_subtract", + ; + + sub _invert { + # Returns a new Range_List that gives all code points not in $self. + + my $self = shift; + + my $new = Range_List->new; + + # Go through each range in the table, finding the gaps between them + my $max = -1; # Set so no gap before range beginning at 0 + for my $range ($self->ranges) { + my $start = $range->start; + my $end = $range->end; + + # If there is a gap before this range, the inverse will contain + # that gap. + if ($start > $max + 1) { + $new->add_range($max + 1, $start - 1); + } + $max = $end; + } + + # And finally, add the gap from the end of the table to the max + # possible code point + if ($max < $LAST_UNICODE_CODEPOINT) { + $new->add_range($max + 1, $LAST_UNICODE_CODEPOINT); + } + return $new; + } + + sub _subtract { + # Returns a new Range_List with the argument deleted from it. The + # argument can be a single code point, a range, or something that has + # a range, with the _range_list() method on it returning them + + my $self = shift; + my $other = shift; + my $reversed = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + if ($reversed) { + Carp::my_carp_bug("Can't cope with a " + . __PACKAGE__ + . " being the second parameter in a '-'. Subtraction ignored."); + return $self; + } + + my $new = Range_List->new(Initialize => $self); + + if (! ref $other) { # Single code point + $new->delete_range($other, $other); + } + elsif ($other->isa('Range')) { + $new->delete_range($other->start, $other->end); + } + elsif ($other->can('_range_list')) { + foreach my $range ($other->_range_list->ranges) { + $new->delete_range($range->start, $range->end); + } + } + else { + Carp::my_carp_bug("Can't cope with a " + . ref($other) + . " argument to '-'. Subtraction ignored." + ); + return $self; + } + + return $new; + } + + sub _intersect { + # Returns either a boolean giving whether the two inputs' range lists + # intersect (overlap), or a new Range_List containing the intersection + # of the two lists. The optional final parameter being true indicates + # to do the check instead of the intersection. + + my $a_object = shift; + my $b_object = shift; + my $check_if_overlapping = shift; + $check_if_overlapping = 0 unless defined $check_if_overlapping; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + if (! defined $b_object) { + my $message = ""; + $message .= $a_object->_owner_name_of if defined $a_object; + Carp::my_carp_bug($message .= "Called with undefined value. Intersection not done."); + return; + } + + # a & b = !(!a | !b), or in our terminology = ~ ( ~a + -b ) + # Thus the intersection could be much more simply be written: + # return ~(~$a_object + ~$b_object); + # But, this is slower, and when taking the inverse of a large + # range_size_1 table, back when such tables were always stored that + # way, it became prohibitively slow, hence the code was changed to the + # below + + if ($b_object->isa('Range')) { + $b_object = Range_List->new(Initialize => $b_object, + Owner => $a_object->_owner_name_of); + } + $b_object = $b_object->_range_list if $b_object->can('_range_list'); + + my @a_ranges = $a_object->ranges; + my @b_ranges = $b_object->ranges; + + #local $to_trace = 1 if main::DEBUG; + trace "intersecting $a_object with ", scalar @a_ranges, "ranges and $b_object with", scalar @b_ranges, " ranges" if main::DEBUG && $to_trace; + + # Start with the first range in each list + my $a_i = 0; + my $range_a = $a_ranges[$a_i]; + my $b_i = 0; + my $range_b = $b_ranges[$b_i]; + + my $new = __PACKAGE__->new(Owner => $a_object->_owner_name_of) + if ! $check_if_overlapping; + + # If either list is empty, there is no intersection and no overlap + if (! defined $range_a || ! defined $range_b) { + return $check_if_overlapping ? 0 : $new; + } + trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace; + + # Otherwise, must calculate the intersection/overlap. Start with the + # very first code point in each list + my $a = $range_a->start; + my $b = $range_b->start; + + # Loop through all the ranges of each list; in each iteration, $a and + # $b are the current code points in their respective lists + while (1) { + + # If $a and $b are the same code point, ... + if ($a == $b) { + + # it means the lists overlap. If just checking for overlap + # know the answer now, + return 1 if $check_if_overlapping; + + # The intersection includes this code point plus anything else + # common to both current ranges. + my $start = $a; + my $end = main::min($range_a->end, $range_b->end); + if (! $check_if_overlapping) { + trace "adding intersection range ", sprintf("%04X", $start) . ".." . sprintf("%04X", $end) if main::DEBUG && $to_trace; + $new->add_range($start, $end); + } + + # Skip ahead to the end of the current intersect + $a = $b = $end; + + # If the current intersect ends at the end of either range (as + # it must for at least one of them), the next possible one + # will be the beginning code point in it's list's next range. + if ($a == $range_a->end) { + $range_a = $a_ranges[++$a_i]; + last unless defined $range_a; + $a = $range_a->start; + } + if ($b == $range_b->end) { + $range_b = $b_ranges[++$b_i]; + last unless defined $range_b; + $b = $range_b->start; + } + + trace "range_a[$a_i]=$range_a; range_b[$b_i]=$range_b" if main::DEBUG && $to_trace; + } + elsif ($a < $b) { + + # Not equal, but if the range containing $a encompasses $b, + # change $a to be the middle of the range where it does equal + # $b, so the next iteration will get the intersection + if ($range_a->end >= $b) { + $a = $b; + } + else { + + # Here, the current range containing $a is entirely below + # $b. Go try to find a range that could contain $b. + $a_i = $a_object->_search_ranges($b); + + # If no range found, quit. + last unless defined $a_i; + + # The search returns $a_i, such that + # range_a[$a_i-1]->end < $b <= range_a[$a_i]->end + # Set $a to the beginning of this new range, and repeat. + $range_a = $a_ranges[$a_i]; + $a = $range_a->start; + } + } + else { # Here, $b < $a. + + # Mirror image code to the leg just above + if ($range_b->end >= $a) { + $b = $a; + } + else { + $b_i = $b_object->_search_ranges($a); + last unless defined $b_i; + $range_b = $b_ranges[$b_i]; + $b = $range_b->start; + } + } + } # End of looping through ranges. + + # Intersection fully computed, or now know that there is no overlap + return $check_if_overlapping ? 0 : $new; + } + + sub overlaps { + # Returns boolean giving whether the two arguments overlap somewhere + + my $self = shift; + my $other = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + return $self->_intersect($other, 1); + } + + sub add_range { + # Add a range to the list. + + my $self = shift; + my $start = shift; + my $end = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + return $self->_add_delete('+', $start, $end, ""); + } + + my $non_ASCII = (ord('A') == 65); # Assumes test on same platform + + sub is_code_point_usable { + # This used only for making the test script. See if the input + # proposed trial code point is one that Perl will handle. If second + # parameter is 0, it won't select some code points for various + # reasons, noted below. + + my $code = shift; + my $try_hard = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + return 0 if $code < 0; # Never use a negative + + # For non-ASCII, we shun the characters that don't have Perl encoding- + # independent symbols for them. 'A' is such a symbol, so is "\n". + # Note, this program hopefully will work on 5.8 Perls, and \v is not + # such a symbol in them. + return $try_hard if $non_ASCII + && $code <= 0xFF + && ($code >= 0x7F + || ($code >= 0x0E && $code <= 0x1F) + || ($code >= 0x01 && $code <= 0x06) + || $code == 0x0B); # \v introduced after 5.8 + + # shun null. I'm (khw) not sure why this was done, but NULL would be + # the character very frequently used. + return $try_hard if $code == 0x0000; + + return 0 if $try_hard; # XXX Temporary until fix utf8.c + + # shun non-character code points. + return $try_hard if $code >= 0xFDD0 && $code <= 0xFDEF; + return $try_hard if ($code & 0xFFFE) == 0xFFFE; # includes FFFF + + return $try_hard if $code > $LAST_UNICODE_CODEPOINT; # keep in range + return $try_hard if $code >= 0xD800 && $code <= 0xDFFF; # no surrogate + + return 1; + } + + sub get_valid_code_point { + # Return a code point that's part of the range list. Returns nothing + # if the table is empty or we can't find a suitable code point. This + # used only for making the test script. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr($self); + + # On first pass, don't choose less desirable code points; if no good + # one is found, repeat, allowing a less desirable one to be selected. + for my $try_hard (0, 1) { + + # Look through all the ranges for a usable code point. + for my $set ($self->ranges) { + + # Try the edge cases first, starting with the end point of the + # range. + my $end = $set->end; + return $end if is_code_point_usable($end, $try_hard); + + # End point didn't, work. Start at the beginning and try + # every one until find one that does work. + for my $trial ($set->start .. $end - 1) { + return $trial if is_code_point_usable($trial, $try_hard); + } + } + } + return (); # If none found, give up. + } + + sub get_invalid_code_point { + # Return a code point that's not part of the table. Returns nothing + # if the table covers all code points or a suitable code point can't + # be found. This used only for making the test script. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # Just find a valid code point of the inverse, if any. + return Range_List->new(Initialize => ~ $self)->get_valid_code_point; + } +} # end closure for Range_List + +package Range_Map; +use base '_Range_List_Base'; + +# A Range_Map is a range list in which the range values (called maps) are +# significant, and hence shouldn't be manipulated by our other code, which +# could be ambiguous or lose things. For example, in taking the union of two +# lists, which share code points, but which have differing values, which one +# has precedence in the union? +# It turns out that these operations aren't really necessary for map tables, +# and so this class was created to make sure they aren't accidentally +# applied to them. + +{ # Closure + + sub add_map { + # Add a range containing a mapping value to the list + + my $self = shift; + # Rest of parameters passed on + + return $self->_add_delete('+', @_); + } + + sub add_duplicate { + # Adds entry to a range list which can duplicate an existing entry + + my $self = shift; + my $code_point = shift; + my $value = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + return $self->add_map($code_point, $code_point, + $value, Replace => $MULTIPLE); + } +} # End of closure for package Range_Map + +package _Base_Table; + +# A table is the basic data structure that gets written out into a file for +# use by the Perl core. This is the abstract base class implementing the +# common elements from the derived ones. A list of the methods to be +# furnished by an implementing class is just after the constructor. + +sub standardize { return main::standardize($_[0]); } +sub trace { return main::trace(@_); } + +{ # Closure + + main::setup_package(); + + my %range_list; + # Object containing the ranges of the table. + main::set_access('range_list', \%range_list, 'p_r', 'p_s'); + + my %full_name; + # The full table name. + main::set_access('full_name', \%full_name, 'r'); + + my %name; + # The table name, almost always shorter + main::set_access('name', \%name, 'r'); + + my %short_name; + # The shortest of all the aliases for this table, with underscores removed + main::set_access('short_name', \%short_name); + + my %nominal_short_name_length; + # The length of short_name before removing underscores + main::set_access('nominal_short_name_length', + \%nominal_short_name_length); + + my %complete_name; + # The complete name, including property. + main::set_access('complete_name', \%complete_name, 'r'); + + my %property; + # Parent property this table is attached to. + main::set_access('property', \%property, 'r'); + + my %aliases; + # Ordered list of aliases of the table's name. The first ones in the list + # are output first in comments + main::set_access('aliases', \%aliases, 'readable_array'); + + my %comment; + # A comment associated with the table for human readers of the files + main::set_access('comment', \%comment, 's'); + + my %description; + # A comment giving a short description of the table's meaning for human + # readers of the files. + main::set_access('description', \%description, 'readable_array'); + + my %note; + # A comment giving a short note about the table for human readers of the + # files. + main::set_access('note', \%note, 'readable_array'); + + my %internal_only; + # Boolean; if set means any file that contains this table is marked as for + # internal-only use. + main::set_access('internal_only', \%internal_only); + + my %find_table_from_alias; + # The parent property passes this pointer to a hash which this class adds + # all its aliases to, so that the parent can quickly take an alias and + # find this table. + main::set_access('find_table_from_alias', \%find_table_from_alias, 'p_r'); + + my %locked; + # After this table is made equivalent to another one; we shouldn't go + # changing the contents because that could mean it's no longer equivalent + main::set_access('locked', \%locked, 'r'); + + my %file_path; + # This gives the final path to the file containing the table. Each + # directory in the path is an element in the array + main::set_access('file_path', \%file_path, 'readable_array'); + + my %status; + # What is the table's status, normal, $OBSOLETE, etc. Enum + main::set_access('status', \%status, 'r'); + + my %status_info; + # A comment about its being obsolete, or whatever non normal status it has + main::set_access('status_info', \%status_info, 'r'); + + my %range_size_1; + # Is the table to be output with each range only a single code point? + # This is done to avoid breaking existing code that may have come to rely + # on this behavior in previous versions of this program.) + main::set_access('range_size_1', \%range_size_1, 'r', 's'); + + my %perl_extension; + # A boolean set iff this table is a Perl extension to the Unicode + # standard. + main::set_access('perl_extension', \%perl_extension, 'r'); + + sub new { + # All arguments are key => value pairs, which you can see below, most + # of which match fields documented above. Otherwise: Pod_Entry, + # Externally_Ok, and Fuzzy apply to the names of the table, and are + # documented in the Alias package + + return Carp::carp_too_few_args(\@_, 2) if main::DEBUG && @_ < 2; + + my $class = shift; + + my $self = bless \do { my $anonymous_scalar }, $class; + my $addr = main::objaddr($self); + + my %args = @_; + + $name{$addr} = delete $args{'Name'}; + $find_table_from_alias{$addr} = delete $args{'_Alias_Hash'}; + $full_name{$addr} = delete $args{'Full_Name'}; + my $complete_name = $complete_name{$addr} + = delete $args{'Complete_Name'}; + $internal_only{$addr} = delete $args{'Internal_Only_Warning'} || 0; + $perl_extension{$addr} = delete $args{'Perl_Extension'} || 0; + $property{$addr} = delete $args{'_Property'}; + $range_list{$addr} = delete $args{'_Range_List'}; + $status{$addr} = delete $args{'Status'} || $NORMAL; + $status_info{$addr} = delete $args{'_Status_Info'} || ""; + $range_size_1{$addr} = delete $args{'Range_Size_1'} || 0; + + my $description = delete $args{'Description'}; + my $externally_ok = delete $args{'Externally_Ok'}; + my $loose_match = delete $args{'Fuzzy'}; + my $note = delete $args{'Note'}; + my $make_pod_entry = delete $args{'Pod_Entry'}; + + # Shouldn't have any left over + Carp::carp_extra_args(\%args) if main::DEBUG && %args; + + # Can't use || above because conceivably the name could be 0, and + # can't use // operator in case this program gets used in Perl 5.8 + $full_name{$addr} = $name{$addr} if ! defined $full_name{$addr}; + + $aliases{$addr} = [ ]; + $comment{$addr} = [ ]; + $description{$addr} = [ ]; + $note{$addr} = [ ]; + $file_path{$addr} = [ ]; + $locked{$addr} = ""; + + push @{$description{$addr}}, $description if $description; + push @{$note{$addr}}, $note if $note; + + # If hasn't set its status already, see if it is on one of the lists + # of properties or tables that have particular statuses; if not, is + # normal. The lists are prioritized so the most serious ones are + # checked first + if (! $status{$addr}) { + if (exists $why_suppressed{$complete_name}) { + $status{$addr} = $SUPPRESSED; + } + elsif (exists $why_deprecated{$complete_name}) { + $status{$addr} = $DEPRECATED; + } + elsif (exists $why_stabilized{$complete_name}) { + $status{$addr} = $STABILIZED; + } + elsif (exists $why_obsolete{$complete_name}) { + $status{$addr} = $OBSOLETE; + } + + # Existence above doesn't necessarily mean there is a message + # associated with it. Use the most serious message. + if ($status{$addr}) { + if ($why_suppressed{$complete_name}) { + $status_info{$addr} + = $why_suppressed{$complete_name}; + } + elsif ($why_deprecated{$complete_name}) { + $status_info{$addr} + = $why_deprecated{$complete_name}; + } + elsif ($why_stabilized{$complete_name}) { + $status_info{$addr} + = $why_stabilized{$complete_name}; + } + elsif ($why_obsolete{$complete_name}) { + $status_info{$addr} + = $why_obsolete{$complete_name}; + } + } + } + + # By convention what typically gets printed only or first is what's + # first in the list, so put the full name there for good output + # clarity. Other routines rely on the full name being first on the + # list + $self->add_alias($full_name{$addr}, + Externally_Ok => $externally_ok, + Fuzzy => $loose_match, + Pod_Entry => $make_pod_entry, + Status => $status{$addr}, + ); + + # Then comes the other name, if meaningfully different. + if (standardize($full_name{$addr}) ne standardize($name{$addr})) { + $self->add_alias($name{$addr}, + Externally_Ok => $externally_ok, + Fuzzy => $loose_match, + Pod_Entry => $make_pod_entry, + Status => $status{$addr}, + ); + } + + return $self; + } + + # Here are the methods that are required to be defined by any derived + # class + for my $sub qw( + append_to_body + pre_body + ) + # append_to_body and pre_body are called in the write() method + # to add stuff after the main body of the table, but before + # its close; and to prepend stuff before the beginning of the + # table. { - my $CName = CanonicalName($Name); - if ($TableInfo{$Type}->{$CName}) { - confess "$0: Use canonical form '$CName' instead of '$Name' for alias."; - } else { - confess "$0: don't have original $Type => $Name to make alias\n"; - } - } - if ($TableInfo{$Alias}) { - confess "$0: already have original $Type => $Alias; can't make alias"; - } - $AliasInfo{$Type}->{$Name} = $Alias; - if ($Fuzzy) { - $FuzzyNames{$Type}->{$Alias} = $Name; - } - -} - - -## All assigned code points -my $Assigned = Table->New(Is => 'Assigned', - Desc => "All assigned code points", - Fuzzy => 0); - -my $Name = Table->New(); ## all characters, individually by name -my $General = Table->New(); ## all characters, grouped by category -my %General; -my %Cat; - -## Simple Data::Dumper like. Good enough for our needs. We can't use the real -## thing as we have to run under miniperl -sub simple_dumper { - my @lines; - my $item; - foreach $item (@_) { - if (ref $item) { - if (ref $item eq 'ARRAY') { - push @lines, "[\n", simple_dumper (@$item), "],\n"; - } elsif (ref $item eq 'HASH') { - push @lines, "{\n", simple_dumper (%$item), "},\n"; - } else { - die "Can't cope with $item"; - } - } else { - if (defined $item) { - my $copy = $item; - $copy =~ s/([\'\\])/\\$1/gs; - push @lines, "'$copy',\n"; - } else { - push @lines, "undef,\n"; - } - } - } - @lines; -} - -## -## Process UnicodeData.txt (Categories, etc.) -## -# These are the character mappings as defined in the POSIX standard -# and in the case of PerlSpace and PerlWord as is defined in the test macros -# for binary strings. IOW, PerlWord is [A-Za-z_] and PerlSpace is [\f\r\n\t ] -# This differs from Word and the existing SpacePerl (note the prefix/suffix difference) -# which is basically the Unicode WhiteSpace without the vertical tab included -# -my %TRUE_POSIX_PERL_CC= ( - PosixAlnum => { map { $_ => 1 } ( 0x0030..0x0039, 0x0041..0x005a, 0x0061..0x007a )}, - PosixAlpha => { map { $_ => 1 } ( 0x0041..0x005a, 0x0061..0x007a )}, - # Not Needed: Ascii => { map { $_ => 1 } ( 0x0000..0x007f )}, - PosixBlank => { map { $_ => 1 } ( 0x0009, 0x0020 )}, - PosixCntrl => { map { $_ => 1 } ( 0x0000..0x001f, 0x007f )}, - PosixGraph => { map { $_ => 1 } ( 0x0021..0x007e )}, - PosixLower => { map { $_ => 1 } ( 0x0061..0x007a )}, - PosixPrint => { map { $_ => 1 } ( 0x0020..0x007e )}, - PosixPunct => { map { $_ => 1 } ( 0x0021..0x002f, 0x003a..0x0040, 0x005b..0x0060, 0x007b..0x007e )}, - PosixSpace => { map { $_ => 1 } ( 0x0009..0x000d, 0x0020 )}, - PosixUpper => { map { $_ => 1 } ( 0x0041..0x005a )}, - # Not needed: PosixXdigit => { map { $_ => 1 } ( 0x0030..0x0039, 0x0041..0x0046, 0x0061..0x0066 )}, - PosixDigit => { map { $_ => 1 } ( 0x0030..0x0039 )}, - - PerlSpace => { map { $_ => 1 } ( 0x0009..0x000a, 0x000c..0x000d, 0x0020 )}, - PerlWord => { map { $_ => 1 } ( 0x0030..0x0039, 0x0041..0x005a, 0x005f, 0x0061..0x007a )}, -); + no strict "refs"; + *$sub = sub { + Carp::my_carp_bug( __LINE__ + . ": Must create method '$sub()' for " + . ref shift); + return; + } + } + + use overload + fallback => 0, + "." => \&main::_operator_dot, + '!=' => \&main::_operator_not_equal, + '==' => \&main::_operator_equal, + ; + + sub ranges { + # Returns the array of ranges associated with this table. + + return $range_list{main::objaddr shift}->ranges; + } + + sub add_alias { + # Add a synonym for this table. + + return Carp::carp_too_few_args(\@_, 3) if main::DEBUG && @_ < 3; + + my $self = shift; + my $name = shift; # The name to add. + my $pointer = shift; # What the alias hash should point to. For + # map tables, this is the parent property; + # for match tables, it is the table itself. + + my %args = @_; + my $loose_match = delete $args{'Fuzzy'}; + + my $make_pod_entry = delete $args{'Pod_Entry'}; + $make_pod_entry = $YES unless defined $make_pod_entry; + + my $externally_ok = delete $args{'Externally_Ok'}; + $externally_ok = 1 unless defined $externally_ok; + + my $status = delete $args{'Status'}; + $status = $NORMAL unless defined $status; -sub UnicodeData_Txt() -{ - my $Bidi = Table->New(); - my $Deco = Table->New(); - my $Comb = Table->New(); - my $Number = Table->New(); - my $Mirrored = Table->New();#Is => 'Mirrored', - #Desc => "Mirrored in bidirectional text", - #Fuzzy => 0); - - my %DC; - my %Bidi; - my %Number; - $DC{Can} = Table->New(); - $DC{Com} = Table->New(); - - ## Initialize Broken Perl-generated categories - ## (Categories from UnicodeData.txt are auto-initialized in gencat) - $Cat{Alnum} = - Table->New(Is => 'Alnum', Desc => "[[:Alnum:]]", Fuzzy => 0); - $Cat{Alpha} = - Table->New(Is => 'Alpha', Desc => "[[:Alpha:]]", Fuzzy => 0); - $Cat{ASCII} = - Table->New(Is => 'ASCII', Desc => "[[:ASCII:]]", Fuzzy => 0); - $Cat{Blank} = - Table->New(Is => 'Blank', Desc => "[[:Blank:]]", Fuzzy => 0); - $Cat{Cntrl} = - Table->New(Is => 'Cntrl', Desc => "[[:Cntrl:]]", Fuzzy => 0); - $Cat{Digit} = - Table->New(Is => 'Digit', Desc => "[[:Digit:]]", Fuzzy => 0); - $Cat{Graph} = - Table->New(Is => 'Graph', Desc => "[[:Graph:]]", Fuzzy => 0); - $Cat{Lower} = - Table->New(Is => 'Lower', Desc => "[[:Lower:]]", Fuzzy => 0); - $Cat{Print} = - Table->New(Is => 'Print', Desc => "[[:Print:]]", Fuzzy => 0); - $Cat{Punct} = - Table->New(Is => 'Punct', Desc => "[[:Punct:]]", Fuzzy => 0); - $Cat{Space} = - Table->New(Is => 'Space', Desc => "[[:Space:]]", Fuzzy => 0); - $Cat{Title} = - Table->New(Is => 'Title', Desc => "[[:Title:]]", Fuzzy => 0); - $Cat{Upper} = - Table->New(Is => 'Upper', Desc => "[[:Upper:]]", Fuzzy => 0); - $Cat{XDigit} = - Table->New(Is => 'XDigit', Desc => "[[:XDigit:]]", Fuzzy => 0); - $Cat{Word} = - Table->New(Is => 'Word', Desc => "[[:Word:]]", Fuzzy => 0); - $Cat{SpacePerl} = - Table->New(Is => 'SpacePerl', Desc => '\s', Fuzzy => 0); - $Cat{VertSpace} = - Table->New(Is => 'VertSpace', Desc => '\v', Fuzzy => 0); - $Cat{HorizSpace} = - Table->New(Is => 'HorizSpace', Desc => '\h', Fuzzy => 0); - my %To; - $To{Upper} = Table->New(); - $To{Lower} = Table->New(); - $To{Title} = Table->New(); - $To{Digit} = Table->New(); - - foreach my $cat (keys %TRUE_POSIX_PERL_CC) { - $Cat{$cat} = Table->New(Is=>$cat, Fuzzy => 0); - } - - sub gencat($$$$) + Carp::carp_extra_args(\%args) if main::DEBUG && %args; + + # Capitalize the first letter of the alias unless it is one of the CJK + # ones which specifically begins with a lower 'k'. Do this because + # Unicode has varied whether they capitalize first letters or not, and + # have later changed their minds and capitalized them, but not the + # other way around. So do it always and avoid changes from release to + # release + $name = ucfirst($name) unless $name =~ /^k[A-Z]/; + + my $addr = main::objaddr $self; + + # Figure out if should be loosely matched if not already specified. + if (! defined $loose_match) { + + # Is a loose_match if isn't null, and doesn't begin with an + # underscore and isn't just a number + if ($name ne "" + && substr($name, 0, 1) ne '_' + && $name !~ qr{^[0-9_.+-/]+$}) + { + $loose_match = 1; + } + else { + $loose_match = 0; + } + } + + # If this alias has already been defined, do nothing. + return if defined $find_table_from_alias{$addr}->{$name}; + + # That includes if it is standardly equivalent to an existing alias, + # in which case, add this name to the list, so won't have to search + # for it again. + my $standard_name = main::standardize($name); + if (defined $find_table_from_alias{$addr}->{$standard_name}) { + $find_table_from_alias{$addr}->{$name} + = $find_table_from_alias{$addr}->{$standard_name}; + return; + } + + # Set the index hash for this alias for future quick reference. + $find_table_from_alias{$addr}->{$name} = $pointer; + $find_table_from_alias{$addr}->{$standard_name} = $pointer; + local $to_trace = 0 if main::DEBUG; + trace "adding alias $name to $pointer" if main::DEBUG && $to_trace; + trace "adding alias $standard_name to $pointer" if main::DEBUG && $to_trace; + + + # Put the new alias at the end of the list of aliases unless the final + # element begins with an underscore (meaning it is for internal perl + # use) or is all numeric, in which case, put the new one before that + # one. This floats any all-numeric or underscore-beginning aliases to + # the end. This is done so that they are listed last in output lists, + # to encourage the user to use a better name (either more descriptive + # or not an internal-only one) instead. This ordering is relied on + # implicitly elsewhere in this program, like in short_name() + my $list = $aliases{$addr}; + my $insert_position = (@$list == 0 + || (substr($list->[-1]->name, 0, 1) ne '_' + && $list->[-1]->name =~ /\D/)) + ? @$list + : @$list - 1; + splice @$list, + $insert_position, + 0, + Alias->new($name, $loose_match, $make_pod_entry, + $externally_ok, $status); + + # This name may be shorter than any existing ones, so clear the cache + # of the shortest, so will have to be recalculated. + undef $short_name{main::objaddr $self}; + return; + } + + sub short_name { + # Returns a name suitable for use as the base part of a file name. + # That is, shorter wins. It can return undef if there is no suitable + # name. The name has all non-essential underscores removed. + + # The optional second parameter is a reference to a scalar in which + # this routine will store the length the returned name had before the + # underscores were removed, or undef if the return is undef. + + # The shortest name can change if new aliases are added. So using + # this should be deferred until after all these are added. The code + # that does that should clear this one's cache. + # Any name with alphabetics is preferred over an all numeric one, even + # if longer. + + my $self = shift; + my $nominal_length_ptr = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + # For efficiency, don't recalculate, but this means that adding new + # aliases could change what the shortest is, so the code that does + # that needs to undef this. + if (defined $short_name{$addr}) { + if ($nominal_length_ptr) { + $$nominal_length_ptr = $nominal_short_name_length{$addr}; + } + return $short_name{$addr}; + } + + # Look at each alias + foreach my $alias ($self->aliases()) { + + # Don't use an alias that isn't ok to use for an external name. + next if ! $alias->externally_ok; + + my $name = main::Standardize($alias->name); + trace $self, $name if main::DEBUG && $to_trace; + + # Take the first one, or a shorter one that isn't numeric. This + # relies on numeric aliases always being last in the array + # returned by aliases(). Any alpha one will have precedence. + if (! defined $short_name{$addr} + || ($name =~ /\D/ + && length($name) < length($short_name{$addr}))) + { + # Remove interior underscores. + ($short_name{$addr} = $name) =~ s/ (?<= . ) _ (?= . ) //xg; + + $nominal_short_name_length{$addr} = length $name; + } + } + + # If no suitable external name return undef + if (! defined $short_name{$addr}) { + $$nominal_length_ptr = undef if $nominal_length_ptr; + return; + } + + # Don't allow a null external name. + if ($short_name{$addr} eq "") { + $short_name{$addr} = '_'; + $nominal_short_name_length{$addr} = 1; + } + + trace $self, $short_name{$addr} if main::DEBUG && $to_trace; + + if ($nominal_length_ptr) { + $$nominal_length_ptr = $nominal_short_name_length{$addr}; + } + return $short_name{$addr}; + } + + sub external_name { + # Returns the external name that this table should be known by. This + # is usually the short_name, but not if the short_name is undefined. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $short = $self->short_name; + return $short if defined $short; + + return '_'; + } + + sub add_description { # Adds the parameter as a short description. + + my $self = shift; + my $description = shift; + chomp $description; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + push @{$description{main::objaddr $self}}, $description; + + return; + } + + sub add_note { # Adds the parameter as a short note. + + my $self = shift; + my $note = shift; + chomp $note; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + push @{$note{main::objaddr $self}}, $note; + + return; + } + + sub add_comment { # Adds the parameter as a comment. + + my $self = shift; + my $comment = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + chomp $comment; + push @{$comment{main::objaddr $self}}, $comment; + + return; + } + + sub comment { + # Return the current comment for this table. If called in list + # context, returns the array of comments. In scalar, returns a string + # of each element joined together with a period ending each. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my @list = @{$comment{main::objaddr $self}}; + return @list if wantarray; + my $return = ""; + foreach my $sentence (@list) { + $return .= '. ' if $return; + $return .= $sentence; + $return =~ s/\.$//; + } + $return .= '.' if $return; + return $return; + } + + sub initialize { + # Initialize the table with the argument which is any valid + # initialization for range lists. + + my $self = shift; + my $initialization = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # Replace the current range list with a new one of the same exact + # type. + my $class = ref $range_list{main::objaddr $self}; + $range_list{main::objaddr $self} = $class->new(Owner => $self, + Initialize => $initialization); + return; + + } + + sub header { + # The header that is output for the table in the file it is written + # in. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $return = ""; + $return .= $DEVELOPMENT_ONLY if $compare_versions; + $return .= $HEADER; + $return .= $INTERNAL_ONLY if $internal_only{main::objaddr $self}; + return $return; + } + + sub write { + # Write a representation of the table to its file. + + my $self = shift; + my $tab_stops = shift; # The number of tab stops over to put any + # comment. + my $suppress_value = shift; # Optional, if the value associated with + # a range equals this one, don't write + # the range + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr($self); + + # Start with the header + my @OUT = $self->header; + + # Then the comments + push @OUT, "\n", main::simple_fold($comment{$addr}, '# '), "\n" + if $comment{$addr}; + + # Then any pre-body stuff. + my $pre_body = $self->pre_body; + push @OUT, $pre_body, "\n" if $pre_body; + + # The main body looks like a 'here' document + push @OUT, "return <<'END';\n"; + + if ($range_list{$addr}->is_empty) { + + # This is a kludge for empty tables to silence a warning in + # utf8.c, which can't really deal with empty tables, but it can + # deal with a table that matches nothing, as the inverse of 'Any' + # does. + push @OUT, "!utf8::IsAny\n"; + } + else { + my $range_size_1 = $range_size_1{$addr}; + + # Output each range as part of the here document. + for my $set ($range_list{$addr}->ranges) { + my $start = $set->start; + my $end = $set->end; + my $value = $set->value; + + # Don't output ranges whose value is the one to suppress + next if defined $suppress_value && $value eq $suppress_value; + + # If has or wants a single point range output + if ($start == $end || $range_size_1) { + for my $i ($start .. $end) { + push @OUT, sprintf "%04X\t\t%s\n", $i, $value; + } + } + else { + push @OUT, sprintf "%04X\t%04X\t%s", $start, $end, $value; + + # Add a comment with the size of the range, if requested. + # Expand Tabs to make sure they all start in the same + # column, and then unexpand to use mostly tabs. + if (! $output_range_counts) { + $OUT[-1] .= "\n"; + } + else { + $OUT[-1] = Text::Tabs::expand($OUT[-1]); + my $count = main::clarify_number($end - $start + 1); + use integer; + + my $width = $tab_stops * 8 - 1; + $OUT[-1] = sprintf("%-*s # [%s]\n", + $width, + $OUT[-1], + $count); + $OUT[-1] = Text::Tabs::unexpand($OUT[-1]); + } + } + } # End of loop through all the table's ranges + } + + # Add anything that goes after the main body, but within the here + # document, + my $append_to_body = $self->append_to_body; + push @OUT, $append_to_body if $append_to_body; + + # And finish the here document. + push @OUT, "END\n"; + + # All these files have a .pl suffix + $file_path{$addr}->[-1] .= '.pl'; + + main::write($file_path{$addr}, \@OUT); + return; + } + + sub set_status { # Set the table's status + my $self = shift; + my $status = shift; # The status enum value + my $info = shift; # Any message associated with it. + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr($self); + + $status{$addr} = $status; + $status_info{$addr} = $info; + return; + } + + sub lock { + # Don't allow changes to the table from now on. This stores a stack + # trace of where it was called, so that later attempts to modify it + # can immediately show where it got locked. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + $locked{$addr} = ""; + + my $line = (caller(0))[2]; + my $i = 1; + + # Accumulate the stack trace + while (1) { + my ($pkg, $file, $caller_line, $caller) = caller $i++; + + last unless defined $caller; + + $locked{$addr} .= " called from $caller() at line $line\n"; + $line = $caller_line; + } + $locked{$addr} .= " called from main at line $line\n"; + + return; + } + + sub carp_if_locked { + # Return whether a table is locked or not, and, by the way, complain + # if is locked + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + return 0 if ! $locked{$addr}; + Carp::my_carp_bug("Can't modify a locked table. Stack trace of locking:\n$locked{$addr}\n\n"); + return 1; + } + + sub set_file_path { # Set the final directory path for this table + my $self = shift; + # Rest of parameters passed on + + @{$file_path{main::objaddr $self}} = @_; + return + } + + # Accessors for the range list stored in this table. First for + # unconditional + for my $sub qw( + contains + count + each_range + hash + is_empty + max + min + range_count + reset_each_range + value_of + ) { - my ($name, ## Name ("LATIN CAPITAL LETTER A") - $cat, ## Category ("Lu", "Zp", "Nd", etc.) - $code, ## Code point (as an integer) - $op) = @_; - - my $MajorCat = substr($cat, 0, 1); ## L, M, Z, S, etc - - $Assigned->$op($code); - $Name->$op($code, $name); - $General->$op($code, $cat); - - ## add to the sub category (e.g. "Lu", "Nd", "Cf", ..) - $Cat{$cat} ||= Table->New(Is => $cat, - Desc => "General Category '$cat'", - Fuzzy => 0); - $Cat{$cat}->$op($code); - - ## add to the major category (e.g. "L", "N", "C", ...) - $Cat{$MajorCat} ||= Table->New(Is => $MajorCat, - Desc => "Major Category '$MajorCat'", - Fuzzy => 0); - $Cat{$MajorCat}->$op($code); - - ($General{$name} ||= Table->New)->$op($code, $name); - - # 005F: SPACING UNDERSCORE - $Cat{Word}->$op($code) if $cat =~ /^[LMN]|Pc/; - $Cat{Alnum}->$op($code) if $cat =~ /^[LM]|Nd/; - $Cat{Alpha}->$op($code) if $cat =~ /^[LM]/; - - my $isspace = - ($cat =~ /Zs|Zl|Zp/ && - $code != 0x200B) # 200B is ZWSP which is for line break control - # and therefore it is not part of "space" even - # while it is "Zs" in some versions of Unicode. - # In 5.1 it is Cf, so this line is no longer - # necessary. - || $code == 0x0009 # 0009: HORIZONTAL TAB - || $code == 0x000A # 000A: LINE FEED - || $code == 0x000B # 000B: VERTICAL TAB - || $code == 0x000C # 000C: FORM FEED - || $code == 0x000D # 000D: CARRIAGE RETURN - || $code == 0x0085 # 0085: NEL - - ; - - $Cat{Space}->$op($code) if $isspace; - - $Cat{SpacePerl}->$op($code) if $isspace - && $code != 0x000B; # Backward compat. - - $Cat{VertSpace}->$op($code) if grep {$code == $_} - ( 0x0A..0x0D,0x85,0x2028,0x2029 ); - - $Cat{HorizSpace}->$op($code) if grep {$code == $_} ( - 0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000, 0x2001, 0x2002, - 0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008, 0x2009, 0x200a, - 0x202f, 0x205f, 0x3000 - ); - - $Cat{Blank}->$op($code) if $isspace - && !($code == 0x000A || - $code == 0x000B || - $code == 0x000C || - $code == 0x000D || - $code == 0x0085 || - $cat =~ /^Z[lp]/); - - $Cat{Digit}->$op($code) if $cat eq "Nd"; - $Cat{Upper}->$op($code) if $cat eq "Lu"; - $Cat{Lower}->$op($code) if $cat eq "Ll"; - $Cat{Title}->$op($code) if $cat eq "Lt"; - $Cat{ASCII}->$op($code) if $code <= 0x007F; - $Cat{Cntrl}->$op($code) if $cat =~ /^C/; - my $isgraph = !$isspace && $cat !~ /Cc|Cs|Cn/; - $Cat{Graph}->$op($code) if $isgraph; - $Cat{Print}->$op($code) if $isgraph || $isspace; - $Cat{Punct}->$op($code) if $cat =~ /^P/; - - $Cat{XDigit}->$op($code) if ($code >= 0x30 && $code <= 0x39) ## 0..9 - || ($code >= 0x41 && $code <= 0x46) ## A..F - || ($code >= 0x61 && $code <= 0x66); ## a..f - if ($code<=0x7F) { - foreach my $cat (keys %TRUE_POSIX_PERL_CC) { - if ($TRUE_POSIX_PERL_CC{$cat}{$code}) { - $Cat{$cat}->$op($code); - } - } - } - } - - ## open and read file..... - if (not open IN, "UnicodeData.txt") { - die "$0: UnicodeData.txt: $!\n"; - } - - ## - ## For building \p{_CombAbove} and \p{_CanonDCIJ} - ## - my %_Above_HexCodes; ## Hexcodes for chars with $comb == 230 ("ABOVE") - - my %CodeToDeco; ## Maps code to decomp. list for chars with first - ## decomp. char an "i" or "j" (for \p{_CanonDCIJ}) - - ## This is filled in as we go.... - my $CombAbove = Table->New(Is => '_CombAbove', - Desc => '(for internal casefolding use)', - Fuzzy => 0); - - while (<IN>) + no strict "refs"; + *$sub = sub { + use strict "refs"; + my $self = shift; + return $range_list{main::objaddr $self}->$sub(@_); + } + } + + # Then for ones that should fail if locked + for my $sub qw( + delete_range + ) { - next unless /^[0-9A-Fa-f]+;/; - s/\s+$//; - - my ($hexcode, ## code point in hex (e.g. "0041") - $name, ## character name (e.g. "LATIN CAPITAL LETTER A") - $cat, ## category (e.g. "Lu") - $comb, ## Canonical combining class (e.g. "230") - $bidi, ## directional category (e.g. "L") - $deco, ## decomposition mapping - $decimal, ## decimal digit value - $digit, ## digit value - $number, ## numeric value - $mirrored, ## mirrored - $unicode10, ## name in Unicode 1.0 - $comment, ## comment field - $upper, ## uppercase mapping - $lower, ## lowercase mapping - $title, ## titlecase mapping - ) = split(/\s*;\s*/); - - # Note that in Unicode 3.2 there will be names like - # LINE FEED (LF), which probably means that \N{} needs - # to cope also with LINE FEED and LF. - $name = $unicode10 if $name eq '<control>' && $unicode10 ne ''; - - my $code = hex($hexcode); - - if ($comb and $comb == 230) { - $CombAbove->Append($code); - $_Above_HexCodes{$hexcode} = 1; - } - - ## Used in building \p{_CanonDCIJ} - if ($deco and $deco =~ m/^006[9A]\b/) { - $CodeToDeco{$code} = $deco; - } - - ## - ## There are a few pairs of lines like: - ## AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;; - ## D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;; - ## that define ranges. - ## - if ($name =~ /^<(.+), (First|Last)>$/) - { - $name = $1; - gencat($name, $cat, $code, $2 eq 'First' ? 'Append' : 'Extend'); - #New_Prop(In => $name, $General{$name}, Fuzzy => 1); + no strict "refs"; + *$sub = sub { + use strict "refs"; + my $self = shift; + + return if $self->carp_if_locked; + return $range_list{main::objaddr $self}->$sub(@_); } - else - { - ## normal (single-character) lines - gencat($name, $cat, $code, 'Append'); + } + +} # End closure + +package Map_Table; +use base '_Base_Table'; + +# A Map Table is a table that contains the mappings from code points to +# values. There are two weird cases: +# 1) Anomalous entries are ones that aren't maps of ranges of code points, but +# are written in the table's file at the end of the table nonetheless. It +# requires specially constructed code to handle these; utf8.c can not read +# these in, so they should not go in $map_directory. As of this writing, +# the only case that these happen is for named sequences used in +# charnames.pm. But this code doesn't enforce any syntax on these, so +# something else could come along that uses it. +# 2) Specials are anything that doesn't fit syntactically into the body of the +# table. The ranges for these have a map type of non-zero. The code below +# knows about and handles each possible type. In most cases, these are +# written as part of the header. +# +# A map table deliberately can't be manipulated at will unlike match tables. +# This is because of the ambiguities having to do with what to do with +# overlapping code points. And there just isn't a need for those things; +# what one wants to do is just query, add, replace, or delete mappings, plus +# write the final result. +# However, there is a method to get the list of possible ranges that aren't in +# this table to use for defaulting missing code point mappings. And, +# map_add_or_replace_non_nulls() does allow one to add another table to this +# one, but it is clearly very specialized, and defined that the other's +# non-null values replace this one's if there is any overlap. + +sub trace { return main::trace(@_); } + +{ # Closure + + main::setup_package(); + + my %default_map; + # Many input files omit some entries; this gives what the mapping for the + # missing entries should be + main::set_access('default_map', \%default_map, 'r'); + + my %anomalous_entries; + # Things that go in the body of the table which don't fit the normal + # scheme of things, like having a range. Not much can be done with these + # once there except to output them. This was created to handle named + # sequences. + main::set_access('anomalous_entry', \%anomalous_entries, 'a'); + main::set_access('anomalous_entries', # Append singular, read plural + \%anomalous_entries, + 'readable_array'); + + my %format; + # The format of the entries of the table. This is calculated from the + # data in the table (or passed in the constructor). This is an enum e.g., + # $STRING_FORMAT + main::set_access('format', \%format); + + my %core_access; + # This is a string, solely for documentation, indicating how one can get + # access to this property via the Perl core. + main::set_access('core_access', \%core_access, 'r', 's'); + + my %has_specials; + # Boolean set when non-zero map-type ranges are added to this table, + # which happens in only a few tables. This is purely for performance, to + # avoid having to search through every table upon output, so if all the + # non-zero maps got deleted before output, this would remain set, and the + # only penalty would be performance. Currently, most map tables that get + # output have specials in them, so this doesn't help that much anyway. + main::set_access('has_specials', \%has_specials); + + my %to_output_map; + # Boolean as to whether or not to write out this map table + main::set_access('to_output_map', \%to_output_map, 's'); + + + sub new { + my $class = shift; + my $name = shift; + + my %args = @_; + + # Optional initialization data for the table. + my $initialize = delete $args{'Initialize'}; + + my $core_access = delete $args{'Core_Access'}; + my $default_map = delete $args{'Default_Map'}; + my $format = delete $args{'Format'}; + my $property = delete $args{'_Property'}; + my $full_name = delete $args{'Full_Name'}; + # Rest of parameters passed on + + my $range_list = Range_Map->new(Owner => $property); + + my $self = $class->SUPER::new( + Name => $name, + Complete_Name => $full_name, + Full_Name => $full_name, + _Property => $property, + _Range_List => $range_list, + %args); + + my $addr = main::objaddr $self; + + $anomalous_entries{$addr} = []; + $core_access{$addr} = $core_access; + $default_map{$addr} = $default_map; + $format{$addr} = $format; + + $self->initialize($initialize) if defined $initialize; + + return $self; + } + + use overload + fallback => 0, + qw("") => "_operator_stringify", + ; + + sub _operator_stringify { + my $self = shift; - # No Append() here since since several codes may map into one. - $To{Upper}->RawAppendRange($code, $code, $upper) if $upper; - $To{Lower}->RawAppendRange($code, $code, $lower) if $lower; - $To{Title}->RawAppendRange($code, $code, $title) if $title; - $To{Digit}->Append($code, $decimal) if length $decimal; + my $name = $self->property->full_name; + $name = '""' if $name eq ""; + return "Map table for Property '$name'"; + } + + sub add_alias { + # Add a synonym for this table (which means the property itself) + my $self = shift; + my $name = shift; + # Rest of parameters passed on. + + $self->SUPER::add_alias($name, $self->property, @_); + return; + } + + sub add_map { + # Add a range of code points to the list of specially-handled code + # points. $MULTI_CP is assumed if the type of special is not passed + # in. + + my $self = shift; + my $lower = shift; + my $upper = shift; + my $string = shift; + my %args = @_; + + my $type = delete $args{'Type'} || 0; + # Rest of parameters passed on + + # Can't change the table if locked. + return if $self->carp_if_locked; + + my $addr = main::objaddr $self; + + $has_specials{$addr} = 1 if $type; + + $self->_range_list->add_map($lower, $upper, + $string, + @_, + Type => $type); + return; + } + + sub append_to_body { + # Adds to the written HERE document of the table's body any anomalous + # entries in the table.. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + return "" unless @{$anomalous_entries{$addr}}; + return join("\n", @{$anomalous_entries{$addr}}) . "\n"; + } - $Bidi->Append($code, $bidi); - $Comb->Append($code, $comb) if $comb; - $Number->Append($code, $number) if length $number; + sub map_add_or_replace_non_nulls { + # This adds the mappings in the table $other to $self. Non-null + # mappings from $other override those in $self. It essentially merges + # the two tables, with the second having priority except for null + # mappings. + + my $self = shift; + my $other = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + return if $self->carp_if_locked; + + if (! $other->isa(__PACKAGE__)) { + Carp::my_carp_bug("$other should be a " + . __PACKAGE__ + . ". Not a '" + . ref($other) + . "'. Not added;"); + return; + } - length($decimal) and ($Number{De} ||= Table->New())->Append($code) - or - length($digit) and ($Number{Di} ||= Table->New())->Append($code) - or - length($number) and ($Number{Nu} ||= Table->New())->Append($code); + my $addr = main::objaddr $self; + my $other_addr = main::objaddr $other; + + local $to_trace = 0 if main::DEBUG; + + my $self_range_list = $self->_range_list; + my $other_range_list = $other->_range_list; + foreach my $range ($other_range_list->ranges) { + my $value = $range->value; + next if $value eq ""; + $self_range_list->_add_delete('+', + $range->start, + $range->end, + $value, + Type => $range->type, + Replace => $UNCONDITIONALLY); + } - $Mirrored->Append($code) if $mirrored eq "Y"; + # Copy the specials information from the other table to $self + if ($has_specials{$other_addr}) { + $has_specials{$addr} = 1; + } - $Bidi{$bidi} ||= Table->New();#Is => "bt/$bidi", - #Desc => "Bi-directional category '$bidi'", - #Fuzzy => 0); - $Bidi{$bidi}->Append($code); + return; + } - if ($deco) + sub set_default_map { + # Define what code points that are missing from the input files should + # map to + + my $self = shift; + my $map = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + # Convert the input to the standard equivalent, if any (won't have any + # for $STRING properties) + my $standard = $self->_find_table_from_alias->{$map}; + $map = $standard->name if defined $standard; + + # Warn if there already is a non-equivalent default map for this + # property. Note that a default map can be a ref, which means that + # what it actually means is delayed until later in the program, and it + # IS permissible to override it here without a message. + my $default_map = $default_map{$addr}; + if (defined $default_map + && ! ref($default_map) + && $default_map ne $map + && main::Standardize($map) ne $default_map) + { + my $property = $self->property; + my $map_table = $property->table($map); + my $default_table = $property->table($default_map); + if (defined $map_table + && defined $default_table + && $map_table != $default_table) { - $Deco->Append($code, $deco); - if ($deco =~/^<(\w+)>/) - { - my $dshort = $PVA_reverse{dt}{ucfirst lc $1}; - $DC{Com}->Append($code); - $dshort = $PVA_reverse{dt}{lc $1} unless $dshort ne ""; - die "No reverse for $1'" unless $dshort ne ""; - #$dshort = lc $dshort; # use lower case only - $DC{$dshort} ||= Table->New(); - $DC{$dshort}->Append($code); - } - else - { - $DC{Can}->Append($code); + Carp::my_carp("Changing the default mapping for " + . $property + . " from $default_map to $map'"); + } + } + + $default_map{$addr} = $map; + + # Don't also create any missing table for this map at this point, + # because if we did, it could get done before the main table add is + # done for PropValueAliases.txt; instead the caller will have to make + # sure it exists, if desired. + return; + } + + sub to_output_map { + # Returns boolean: should we write this map table? + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + # If overridden, use that + return $to_output_map{$addr} if defined $to_output_map{$addr}; + + my $full_name = $self->full_name; + + # If table says to output, do so; if says to suppress it, do do. + return 1 if grep { $_ eq $full_name } @output_mapped_properties; + return 0 if $self->status eq $SUPPRESSED; + + my $type = $self->property->type; + + # Don't want to output binary map tables even for debugging. + return 0 if $type == $BINARY; + + # But do want to output string ones. + return 1 if $type == $STRING; + + # Otherwise is an $ENUM, don't output it + return 0; + } + + sub inverse_list { + # Returns a Range_List that is gaps of the current table. That is, + # the inversion + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $current = Range_List->new(Initialize => $self->_range_list, + Owner => $self->property); + return ~ $current; + } + + sub set_final_comment { + # Just before output, create the comment that heads the file + # containing this table. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # No sense generating a comment if aren't going to write it out. + return if ! $self->to_output_map; + + my $addr = main::objaddr $self; + + my $property = $self->property; + + # Get all the possible names for this property. Don't use any that + # aren't ok for use in a file name, etc. This is perhaps causing that + # flag to do double duty, and may have to be changed in the future to + # have our own flag for just this purpose; but it works now to exclude + # Perl generated synonyms from the lists for properties, where the + # name is always the proper Unicode one. + my @property_aliases = grep { $_->externally_ok } $self->aliases; + + my $count = $self->count; + my $default_map = $default_map{$addr}; + + # The ranges that map to the default aren't output, so subtract that + # to get those actually output. A property with matching tables + # already has the information calculated. + if ($property->type != $STRING) { + $count -= $property->table($default_map)->count; + } + elsif (defined $default_map) { + + # But for $STRING properties, must calculate now. Subtract the + # count from each range that maps to the default. + foreach my $range ($self->_range_list->ranges) { + if ($range->value eq $default_map) { + $count -= $range->end +1 - $range->start; + } + } + + } + + # Get a string version of $count with underscores in large numbers, + # for clarity. + my $string_count = main::clarify_number($count); + + my $code_points = ($count == 1) + ? 'single code point' + : "$string_count code points"; + + my $mapping; + my $these_mappings; + my $are; + if (@property_aliases <= 1) { + $mapping = 'mapping'; + $these_mappings = 'this mapping'; + $are = 'is' + } + else { + $mapping = 'synonymous mappings'; + $these_mappings = 'these mappings'; + $are = 'are' + } + my $cp; + if ($count >= $MAX_UNICODE_CODEPOINTS) { + $cp = "any code point in Unicode Version $string_version"; + } + else { + my $map_to; + if ($default_map eq "") { + $map_to = 'the null string'; + } + elsif ($default_map eq $CODE_POINT) { + $map_to = "itself"; + } + else { + $map_to = "'$default_map'"; + } + if ($count == 1) { + $cp = "the single code point"; + } + else { + $cp = "one of the $code_points"; + } + $cp .= " in Unicode Version $string_version for which the mapping is not to $map_to"; + } + + my $comment = ""; + + my $status = $self->status; + if ($status) { + my $warn = uc $status_past_participles{$status}; + $comment .= <<END; + +!!!!!!! $warn !!!!!!!!!!!!!!!!!!! + All property or property=value combinations contained in this file are $warn. + See $unicode_reference_url for what this means. + +END + } + $comment .= "This file returns the $mapping:\n"; + + for my $i (0 .. @property_aliases - 1) { + $comment .= sprintf("%-8s%s\n", + " ", + $property_aliases[$i]->name . '(cp)' + ); + } + $comment .= + "\nwhere 'cp' is $cp. Note that $these_mappings $are "; + + my $access = $core_access{$addr}; + if ($access) { + $comment .= "accessible through the Perl core via $access."; + } + else { + $comment .= "not accessible through the Perl core directly."; + } + + # And append any commentary already set from the actual property. + $comment .= "\n\n" . $self->comment if $self->comment; + if ($self->description) { + $comment .= "\n\n" . join " ", $self->description; + } + if ($self->note) { + $comment .= "\n\n" . join " ", $self->note; + } + $comment .= "\n"; + + if (! $self->perl_extension) { + $comment .= <<END; + +For information about what this property really means, see: +$unicode_reference_url +END + } + + if ($count) { # Format differs for empty table + $comment.= "\nThe format of the "; + if ($self->range_size_1) { + $comment.= <<END; +main body of lines of this file is: CODE_POINT\\t\\tMAPPING where CODE_POINT +is in hex; MAPPING is what CODE_POINT maps to. +END + } + else { + + # There are tables which end up only having one element per + # range, but it is not worth keeping track of for making just + # this comment a little better. + $comment.= <<END; +non-comment portions of the main body of lines of this file is: +START\\tSTOP\\tMAPPING where START is the starting code point of the +range, in hex; STOP is the ending point, or if omitted, the range has just one +code point; MAPPING is what each code point between START and STOP maps to. +END + if ($output_range_counts) { + $comment .= <<END; +Numbers in comments in [brackets] indicate how many code points are in the +range (omitted when the range is a single code point or if the mapping is to +the null string). +END } } } + $self->set_comment(main::join_lines($comment)); + return; } - close IN; - ## Read in the NameAliases.txt. It contains other normative names of code - ## points not listed in UnicodeData.txt. This happens when there is an - ## error in the name found after the data base was published, but instead of - ## changing it, to avoid breaking any code that came to rely on the - ## erroneous version, the correct name is added as an alias. - - my $NameAliases = Table->New(); + my %swash_keys; # Makes sure don't duplicate swash names. - if (not open IN, "NameAliases.txt") { - die "$0: NameAliases.txt: $!\n"; + sub pre_body { + # Returns the string that should be output in the file before the main + # body of this table. This includes some hash entries identifying the + # format of the body, and what the single value should be for all + # ranges missing from it. It also includes any code points which have + # map_types that don't go in the main table. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + my $name = $self->property->swash_name; + + if (defined $swash_keys{$name}) { + Carp::my_carp(join_lines(<<END +Already created a swash name '$name' for $swash_keys{$name}. This means that +the same name desired for $self shouldn't be used. Bad News. This must be +fixed before production use, but proceeding anyway +END + )); + } + $swash_keys{$name} = "$self"; + + my $default_map = $default_map{$addr}; + + my $pre_body = ""; + if ($has_specials{$addr}) { + + # Here, some maps with non-zero type have been added to the table. + # Go through the table and handle each of them. None will appear + # in the body of the table, so delete each one as we go. The + # code point count has already been calculated, so ok to delete + # now. + + my @multi_code_point_maps; + my $has_hangul_syllables = 0; + + # The key is the base name of the code point, and the value is an + # array giving all the ranges that use this base name. Each range + # is actually a hash giving the 'low' and 'high' values of it. + my %names_ending_in_code_point; + + # Inverse mapping. The list of ranges that have these kinds of + # names. Each element contains the low, high, and base names in a + # hash. + my @code_points_ending_in_code_point; + + my $range_map = $self->_range_list; + foreach my $range ($range_map->ranges) { + next unless $range->type != 0; + my $low = $range->start; + my $high = $range->end; + my $map = $range->value; + my $type = $range->type; + + # No need to output the range if it maps to the default. And + # the write method won't output it either, so no need to + # delete it to keep it from being output, and is faster to + # skip than to delete anyway. + next if $map eq $default_map; + + # Delete the range to keep write() from trying to output it + $range_map->delete_range($low, $high); + + # Switch based on the map type... + if ($type == $HANGUL_SYLLABLE) { + + # These are entirely algorithmically determinable based on + # some constants furnished by Unicode; for now, just set a + # flag to indicate that have them. Below we will output + # the code that does the algorithm. + $has_hangul_syllables = 1; + } + elsif ($type == $CP_IN_NAME) { + + # If the name ends in the code point it represents, are + # also algorithmically determinable, but need information + # about the map to do so. Both the map and its inverse + # are stored in data structures output in the file. + push @{$names_ending_in_code_point{$map}->{'low'}}, $low; + push @{$names_ending_in_code_point{$map}->{'high'}}, $high; + + push @code_points_ending_in_code_point, { low => $low, + high => $high, + name => $map + }; + } + elsif ($range->type == $MULTI_CP || $range->type == $NULL) { + + # Multi-code point maps and null string maps have an entry + # for each code point in the range. They use the same + # output format. + for my $code_point ($low .. $high) { + + # The pack() below can't cope with surrogates. + if ($code_point >= 0xD800 && $code_point <= 0xDFFF) { + Carp::my_carp("Surrogage code point '$code_point' in mapping to '$map' in $self. No map created"); + next; + } + + # Generate the hash entries for these in the form that + # utf8.c understands. + my $tostr = ""; + foreach my $to (split " ", $map) { + if ($to !~ /^$code_point_re$/) { + Carp::my_carp("Illegal code point '$to' in mapping '$map' from $code_point in $self. No map created"); + next; + } + $tostr .= sprintf "\\x{%s}", $to; + } + + # I (khw) have never waded through this line to + # understand it well enough to comment it. + my $utf8 = sprintf(qq["%s" => "$tostr",], + join("", map { sprintf "\\x%02X", $_ } + unpack("U0C*", pack("U", $code_point)))); + + # Add a comment so that a human reader can more easily + # see what's going on. + push @multi_code_point_maps, + sprintf("%-45s # U+%04X => %s", $utf8, + $code_point, + $map); + } + } + else { + Carp::my_carp("Unrecognized map type '$range->type' in '$range' in $self. Using type 0 instead"); + $range_map->add_map($low, $high, $map, Replace => $UNCONDITIONALLY, Type => 0); + } + } # End of loop through all ranges + + # Here have gone through the whole file. If actually generated + # anything for each map type, add its respective header and + # trailer + if (@multi_code_point_maps) { + $pre_body .= <<END; + +# Some code points require special handling because their mappings are each to +# multiple code points. These do not appear in the main body, but are defined +# in the hash below. + +# The key: UTF-8 _bytes_, the value: UTF-8 (speed hack) +%utf8::ToSpec$name = ( +END + $pre_body .= join("\n", @multi_code_point_maps) . "\n);\n"; + } + + if ($has_hangul_syllables || @code_points_ending_in_code_point) { + + # Convert these structures to output format. + my $code_points_ending_in_code_point = + main::simple_dumper(\@code_points_ending_in_code_point, + ' ' x 8); + my $names = main::simple_dumper(\%names_ending_in_code_point, + ' ' x 8); + + # Do the same with the Hangul names, + my $jamo; + my $jamo_l; + my $jamo_v; + my $jamo_t; + my $jamo_re; + if ($has_hangul_syllables) { + + # Construct a regular expression of all the possible + # combinations of the Hangul syllables. + my @L_re; # Leading consonants + for my $i ($LBase .. $LBase + $LCount - 1) { + push @L_re, $Jamo{$i} + } + my @V_re; # Middle vowels + for my $i ($VBase .. $VBase + $VCount - 1) { + push @V_re, $Jamo{$i} + } + my @T_re; # Trailing consonants + for my $i ($TBase + 1 .. $TBase + $TCount - 1) { + push @T_re, $Jamo{$i} + } + + # The whole re is made up of the L V T combination. + $jamo_re = '(' + . join ('|', sort @L_re) + . ')(' + . join ('|', sort @V_re) + . ')(' + . join ('|', sort @T_re) + . ')?'; + + # These hashes needed by the algorithm were generated + # during reading of the Jamo.txt file + $jamo = main::simple_dumper(\%Jamo, ' ' x 8); + $jamo_l = main::simple_dumper(\%Jamo_L, ' ' x 8); + $jamo_v = main::simple_dumper(\%Jamo_V, ' ' x 8); + $jamo_t = main::simple_dumper(\%Jamo_T, ' ' x 8); + } + + $pre_body .= <<END; + +# To achieve significant memory savings when this file is read in, +# algorithmically derivable code points are omitted from the main body below. +# Instead, the following routines can be used to translate between name and +# code point and vice versa + +{ # Closure + + # Matches legal code point. 4-6 hex numbers, If there are 6, the + # first two must be '10'; if there are 5, the first must not be a '0'. + my \$code_point_re = qr/$code_point_re/; + + # In the following hash, the keys are the bases of names which includes + # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values + # of each key is another hash which is used to get the low and high ends + # for each range of code points that apply to the name + my %names_ending_in_code_point = ( +$names + ); + + # And the following array gives the inverse mapping from code points to + # names. Lowest code points are first + my \@code_points_ending_in_code_point = ( +$code_points_ending_in_code_point + ); +END + # Earlier releases didn't have Jamos. No sense outputting + # them unless will be used. + if ($has_hangul_syllables) { + $pre_body .= <<END; + + # Convert from code point to Jamo short name for use in composing Hangul + # syllable names + my %Jamo = ( +$jamo + ); + + # Leading consonant (can be null) + my %Jamo_L = ( +$jamo_l + ); + + # Vowel + my %Jamo_V = ( +$jamo_v + ); + + # Optional trailing consonant + my %Jamo_T = ( +$jamo_t + ); + + # Computed re that splits up a Hangul name into LVT or LV syllables + my \$syllable_re = qr/$jamo_re/; + + my \$HANGUL_SYLLABLE = "HANGUL SYLLABLE "; + my \$HANGUL_SYLLABLE_LENGTH = length \$HANGUL_SYLLABLE; + + # These constants names and values were taken from the Unicode standard, + # version 5.1, section 3.12. They are used in conjunction with Hangul + # syllables + my \$SBase = 0xAC00; + my \$LBase = 0x1100; + my \$VBase = 0x1161; + my \$TBase = 0x11A7; + my \$SCount = 11172; + my \$LCount = 19; + my \$VCount = 21; + my \$TCount = 28; + my \$NCount = \$VCount * \$TCount; +END + } # End of has Jamos + + $pre_body .= << 'END'; + + sub name_to_code_point_special { + my $name = shift; + + # Returns undef if not one of the specially handled names; otherwise + # returns the code point equivalent to the input name +END + if ($has_hangul_syllables) { + $pre_body .= << 'END'; + + if (substr($name, 0, $HANGUL_SYLLABLE_LENGTH) eq $HANGUL_SYLLABLE) { + $name = substr($name, $HANGUL_SYLLABLE_LENGTH); + return if $name !~ qr/^$syllable_re$/; + my $L = $Jamo_L{$1}; + my $V = $Jamo_V{$2}; + my $T = (defined $3) ? $Jamo_T{$3} : 0; + return ($L * $VCount + $V) * $TCount + $T + $SBase; + } +END + } + $pre_body .= << 'END'; + + # Name must end in '-code_point' for this to handle. + if ($name !~ /^ (.*) - ($code_point_re) $/x) { + return; + } + + my $base = $1; + my $code_point = CORE::hex $2; + + # Name must be one of the ones which has the code point in it. + return if ! $names_ending_in_code_point{$base}; + + # Look through the list of ranges that apply to this name to see if + # the code point is in one of them. + for (my $i = 0; $i < scalar @{$names_ending_in_code_point{$base}{'low'}}; $i++) { + return if $names_ending_in_code_point{$base}{'low'}->[$i] > $code_point; + next if $names_ending_in_code_point{$base}{'high'}->[$i] < $code_point; + + # Here, the code point is in the range. + return $code_point; + } + + # Here, looked like the name had a code point number in it, but + # did not match one of the valid ones. + return; + } + + sub code_point_to_name_special { + my $code_point = shift; + + # Returns the name of a code point if algorithmically determinable; + # undef if not +END + if ($has_hangul_syllables) { + $pre_body .= << 'END'; + + # If in the Hangul range, calculate the name based on Unicode's + # algorithm + if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) { + use integer; + my $SIndex = $code_point - $SBase; + my $L = $LBase + $SIndex / $NCount; + my $V = $VBase + ($SIndex % $NCount) / $TCount; + my $T = $TBase + $SIndex % $TCount; + $name = "$HANGUL_SYLLABLE $Jamo{$L}$Jamo{$V}"; + $name .= $Jamo{$T} if $T != $TBase; + return $name; + } +END + } + $pre_body .= << 'END'; + + # Look through list of these code points for one in range. + foreach my $hash (@code_points_ending_in_code_point) { + return if $code_point < $hash->{'low'}; + if ($code_point <= $hash->{'high'}) { + return sprintf("%s-%04X", $hash->{'name'}, $code_point); + } + } + return; # None found + } +} # End closure + +END + } # End of has hangul or code point in name maps. + } # End of has specials + + # Calculate the format of the table if not already done. + my $format = $format{$addr}; + my $property = $self->property; + my $type = $property->type; + if (! defined $format) { + if ($type == $BINARY) { + + # Don't bother checking the values, because we elsewhere + # verify that a binary table has only 2 values. + $format = $BINARY_FORMAT; + } + else { + my @ranges = $self->_range_list->ranges; + + # default an empty table based on its type and default map + if (! @ranges) { + + # But it turns out that the only one we can say is a + # non-string (besides binary, handled above) is when the + # table is a string and the default map is to a code point + if ($type == $STRING && $default_map eq $CODE_POINT) { + $format = $HEX_FORMAT; + } + else { + $format = $STRING_FORMAT; + } + } + else { + + # Start with the most restrictive format, and as we find + # something that doesn't fit with that, change to the next + # most restrictive, and so on. + $format = $DECIMAL_FORMAT; + foreach my $range (@ranges) { + my $map = $range->value; + if ($map ne $default_map) { + last if $format eq $STRING_FORMAT; # already at + # least + # restrictive + $format = $INTEGER_FORMAT + if $format eq $DECIMAL_FORMAT + && $map !~ / ^ [0-9] $ /x; + $format = $FLOAT_FORMAT + if $format eq $INTEGER_FORMAT + && $map !~ / ^ -? [0-9]+ $ /x; + $format = $RATIONAL_FORMAT + if $format eq $FLOAT_FORMAT + && $map !~ / ^ -? [0-9]+ \. [0-9]* $ /x; + $format = $HEX_FORMAT + if $format eq $RATIONAL_FORMAT + && $map !~ / ^ -? [0-9]+ ( \/ [0-9]+ )? $ /x; + $format = $STRING_FORMAT if $format eq $HEX_FORMAT + && $map =~ /[^0-9A-F]/; + } + } + } + } + } # end of calculating format + + my $return = <<END; +# The name this swash is to be known by, with the format of the mappings in +# the main body of the table, and what all code points missing from this file +# map to. +\$utf8::SwashInfo{'To$name'}{'format'} = '$format'; # $map_table_formats{$format} +END + my $missing = $default_map; + if ($missing eq $CODE_POINT + && $format ne $HEX_FORMAT + && ! defined $format{$addr}) # Is expected if was manually set + { + Carp::my_carp_bug("Expecting hex format for mapping table for $self, instead got '$format'") + } + $format{$addr} = $format; + $return .= "\$utf8::SwashInfo{'To$name'}{'missing'} = '$missing';"; + if ($missing eq $CODE_POINT) { + $return .= ' # code point maps to itself'; + } + elsif ($missing eq "") { + $return .= ' # code point maps to the null string'; + } + $return .= "\n"; + + $return .= $pre_body; + + return $return; } - while (<IN>) + sub write { + # Write the table to the file. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + return $self->SUPER::write( + ($self->property == $block) + ? 7 # block file needs more tab stops + : 3, + $default_map{$addr}); # don't write defaulteds + } + + # Accessors for the underlying list that should fail if locked. + for my $sub qw( + add_duplicate + ) { - next unless /^[0-9A-Fa-f]+;/; - s/\s+$//; - - my ($hexcode, ## code point in hex (e.g. "0041") - $name, ## character name (e.g. "LATIN CAPITAL LETTER A") - ) = split(/\s*;\s*/); - - my $code = hex($hexcode); - - ## One is supposed to enter elements into tables in strictly increasing - ## order, but this in fact works to append duplicate code points at - ## the end of the table. The table is intended to be indexed by name - ## anyway. - - $Name->RawAppendRange($code, $code, $name); - } - close IN; - - - ## - ## Tidy up a few special cases.... - ## - - $Cat{Cn} = $Assigned->Invert; ## Cn is everything that doesn't exist - New_Prop(Is => 'Cn', - $Cat{Cn}, - Desc => "General Category 'Cn' [not functional in Perl]", - Fuzzy => 0); - - ## Unassigned is the same as 'Cn' - New_Alias(Is => 'Unassigned', SameAs => 'Cn', Fuzzy => 0); - - $Cat{C}->Replace($Cat{C}->Merge($Cat{Cn})); ## Now merge in Cn into C - - - # LC is Ll, Lu, and Lt. - # (used to be L& or L_, but PropValueAliases.txt defines it as LC) - New_Prop(Is => 'LC', - Table->Merge(@Cat{qw[Ll Lu Lt]}), - Desc => '[\p{Ll}\p{Lu}\p{Lt}]', - Fuzzy => 0); - - ## Any and All are all code points. - my $Any = Table->New(Is => 'Any', - Desc => sprintf("[\\x{0000}-\\x{%X}]", - $LastUnicodeCodepoint), - Fuzzy => 0); - $Any->RawAppendRange(0, $LastUnicodeCodepoint); - - New_Alias(Is => 'All', SameAs => 'Any', Fuzzy => 0); - - ## - ## Build special properties for Perl's internal case-folding needs: - ## \p{_CaseIgnorable} - ## \p{_CanonDCIJ} - ## \p{_CombAbove} - ## _CombAbove was built above. Others are built here.... - ## - - ## \p{_CaseIgnorable} is [\p{Mn}\0x00AD\x2010] - New_Prop(Is => '_CaseIgnorable', - Table->Merge($Cat{Mn}, - 0x00AD, #SOFT HYPHEN - 0x2010), #HYPHEN - Desc => '(for internal casefolding use)', - Fuzzy => 0); - - - ## \p{_CanonDCIJ} is fairly complex... - my $CanonCDIJ = Table->New(Is => '_CanonDCIJ', - Desc => '(for internal casefolding use)', - Fuzzy => 0); - ## It contains the ASCII 'i' and 'j'.... - $CanonCDIJ->Append(0x0069); # ASCII ord("i") - $CanonCDIJ->Append(0x006A); # ASCII ord("j") - ## ...and any character with a decomposition that starts with either of - ## those code points, but only if the decomposition does not have any - ## combining character with the "ABOVE" canonical combining class. - for my $code (sort { $a <=> $b} keys %CodeToDeco) + no strict "refs"; + *$sub = sub { + use strict "refs"; + my $self = shift; + + return if $self->carp_if_locked; + return $self->_range_list->$sub(@_); + } + } +} # End closure for Map_Table + +package Match_Table; +use base '_Base_Table'; + +# A Match table is one which is a list of all the code points that have +# the same property and property value, for use in \p{property=value} +# constructs in regular expressions. It adds very little data to the base +# structure, but many methods, as these lists can be combined in many ways to +# form new ones. +# There are only a few concepts added: +# 1) Equivalents and Relatedness. +# Two tables can match the identical code points, but have different names. +# This always happens when there is a perl single form extension +# \p{IsProperty} for the Unicode compound form \P{Property=True}. The two +# tables are set to be related, with the Perl extension being a child, and +# the Unicode property being the parent. +# +# It may be that two tables match the identical code points and we don't +# know if they are related or not. This happens most frequently when the +# Block and Script properties have the exact range. But note that a +# revision to Unicode could add new code points to the script, which would +# now have to be in a different block (as the block was filled, or there +# would have been 'Unknown' script code points in it and they wouldn't have +# been identical). So we can't rely on any two properties from Unicode +# always matching the same code points from release to release, and thus +# these tables are considered coincidentally equivalent--not related. When +# two tables are unrelated but equivalent, one is arbitrarily chosen as the +# 'leader', and the others are 'equivalents'. This concept is useful +# to minimize the number of tables written out. Only one file is used for +# any identical set of code points, with entries in Heavy.pl mapping all +# the involved tables to it. +# +# Related tables will always be identical; we set them up to be so. Thus +# if the Unicode one is deprecated, the Perl one will be too. Not so for +# unrelated tables. Relatedness makes generating the documentation easier. +# +# 2) Conflicting. It may be that there will eventually be name clashes, with +# the same name meaning different things. For a while, there actually were +# conflicts, but they have so far been resolved by changing Perl's or +# Unicode's definitions to match the other, but when this code was written, +# it wasn't clear that that was what was going to happen. (Unicode changed +# because of protests during their beta period.) Name clashes are warned +# about during compilation, and the documentation. The generated tables +# are sane, free of name clashes, because the code suppresses the Perl +# version. But manual intervention to decide what the actual behavior +# should be may be required should this happen. The introductory comments +# have more to say about this. + +sub standardize { return main::standardize($_[0]); } +sub trace { return main::trace(@_); } + + +{ # Closure + + main::setup_package(); + + my %leader; + # The leader table of this one; initially $self. + main::set_access('leader', \%leader, 'r'); + + my %equivalents; + # An array of any tables that have this one as their leader + main::set_access('equivalents', \%equivalents, 'readable_array'); + + my %parent; + # The parent table to this one, initially $self. This allows us to + # distinguish between equivalent tables that are related, and those which + # may not be, but share the same output file because they match the exact + # same set of code points in the current Unicode release. + main::set_access('parent', \%parent, 'r'); + + my %children; + # An array of any tables that have this one as their parent + main::set_access('children', \%children, 'readable_array'); + + my %conflicting; + # Array of any tables that would have the same name as this one with + # a different meaning. This is used for the generated documentation. + main::set_access('conflicting', \%conflicting, 'readable_array'); + + my %matches_all; + # Set in the constructor for tables that are expected to match all code + # points. + main::set_access('matches_all', \%matches_all, 'r'); + + sub new { + my $class = shift; + + my %args = @_; + + # The property for which this table is a listing of property values. + my $property = delete $args{'_Property'}; + + my $name = delete $args{'Name'}; + my $full_name = delete $args{'Full_Name'}; + $full_name = $name if ! defined $full_name; + + # Optional + my $initialize = delete $args{'Initialize'}; + my $matches_all = delete $args{'Matches_All'} || 0; + # Rest of parameters passed on. + + my $range_list = Range_List->new(Initialize => $initialize, + Owner => $property); + + my $complete = $full_name; + $complete = '""' if $complete eq ""; # A null name shouldn't happen, + # but this helps debug if it + # does + # The complete name for a match table includes it's property in a + # compound form 'property=table', except if the property is the + # pseudo-property, perl, in which case it is just the single form, + # 'table' (If you change the '=' must also change the ':' in lots of + # places in this program that assume an equal sign) + $complete = $property->full_name . "=$complete" if $property != $perl; + + + my $self = $class->SUPER::new(%args, + Name => $name, + Complete_Name => $complete, + Full_Name => $full_name, + _Property => $property, + _Range_List => $range_list, + ); + my $addr = main::objaddr $self; + + $conflicting{$addr} = [ ]; + $equivalents{$addr} = [ ]; + $children{$addr} = [ ]; + $matches_all{$addr} = $matches_all; + $leader{$addr} = $self; + $parent{$addr} = $self; + + return $self; + } + + # See this program's beginning comment block about overloading these. + use overload + fallback => 0, + qw("") => "_operator_stringify", + '=' => sub { + my $self = shift; + + return if $self->carp_if_locked; + return $self; + }, + + '+' => sub { + my $self = shift; + my $other = shift; + + return $self->_range_list + $other; + }, + '&' => sub { + my $self = shift; + my $other = shift; + + return $self->_range_list & $other; + }, + '+=' => sub { + my $self = shift; + my $other = shift; + + return if $self->carp_if_locked; + + my $addr = main::objaddr $self; + + if (ref $other) { + + # Change the range list of this table to be the + # union of the two. + $self->_set_range_list($self->_range_list + + $other); + } + else { # $other is just a simple value + $self->add_range($other, $other); + } + return $self; + }, + '-' => sub { my $self = shift; + my $other = shift; + my $reversed = shift; + + if ($reversed) { + Carp::my_carp_bug("Can't cope with a " + . __PACKAGE__ + . " being the first parameter in a '-'. Subtraction ignored."); + return; + } + + return $self->_range_list - $other; + }, + '~' => sub { my $self = shift; + return ~ $self->_range_list; + }, + ; + + sub _operator_stringify { + my $self = shift; + + my $name = $self->complete_name; + return "Table '$name'"; + } + + sub add_alias { + # Add a synonym for this table. See the comments in the base class + + my $self = shift; + my $name = shift; + # Rest of parameters passed on. + + $self->SUPER::add_alias($name, $self, @_); + return; + } + + sub add_conflicting { + # Add the name of some other object to the list of ones that name + # clash with this match table. + + my $self = shift; + my $conflicting_name = shift; # The name of the conflicting object + my $p = shift || 'p'; # Optional, is this a \p{} or \P{} ? + my $conflicting_object = shift; # Optional, the conflicting object + # itself. This is used to + # disambiguate the text if the input + # name is identical to any of the + # aliases $self is known by. + # Sometimes the conflicting object is + # merely hypothetical, so this has to + # be an optional parameter. + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + # Check if the conflicting name is exactly the same as any existing + # alias in this table (as long as there is a real object there to + # disambiguate with). + if (defined $conflicting_object) { + foreach my $alias ($self->aliases) { + if ($alias->name eq $conflicting_name) { + + # Here, there is an exact match. This results in + # ambiguous comments, so disambiguate by changing the + # conflicting name to its object's complete equivalent. + $conflicting_name = $conflicting_object->complete_name; + last; + } + } + } + + # Convert to the \p{...} final name + $conflicting_name = "\\$p" . "{$conflicting_name}"; + + # Only add once + return if grep { $conflicting_name eq $_ } @{$conflicting{$addr}}; + + push @{$conflicting{$addr}}, $conflicting_name; + + return; + } + + sub is_equivalent_to { + # Return boolean of whether or not the other object is a table of this + # type and has been marked equivalent to this one. + + my $self = shift; + my $other = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + return 0 if ! defined $other; # Can happen for incomplete early + # releases + unless ($other->isa(__PACKAGE__)) { + my $ref_other = ref $other; + my $ref_self = ref $self; + Carp::my_carp_bug("Argument to 'is_equivalent_to' must be another $ref_self, not a '$ref_other'. $other not set equivalent to $self."); + return 0; + } + + # Two tables are equivalent if they have the same leader. + return $leader{main::objaddr $self} + == $leader{main::objaddr $other}; + return; + } + + sub matches_identically_to { + # Return a boolean as to whether or not two tables match identical + # sets of code points. + + my $self = shift; + my $other = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + unless ($other->isa(__PACKAGE__)) { + my $ref_other = ref $other; + my $ref_self = ref $self; + Carp::my_carp_bug("Argument to 'matches_identically_to' must be another $ref_self, not a '$ref_other'. $other not set equivalent to $self."); + return 0; + } + + # These are ordered in increasing real time to figure out (at least + # until a patch changes that and doesn't change this) + return 0 if $self->max != $other->max; + return 0 if $self->min != $other->min; + return 0 if $self->range_count != $other->range_count; + return 0 if $self->count != $other->count; + + # Here they could be identical because all the tests above passed. + # The loop below is somewhat simpler since we know they have the same + # number of elements. Compare range by range, until reach the end or + # find something that differs. + my @a_ranges = $self->_range_list->ranges; + my @b_ranges = $other->_range_list->ranges; + for my $i (0 .. @a_ranges - 1) { + my $a = $a_ranges[$i]; + my $b = $b_ranges[$i]; + trace "self $a; other $b" if main::DEBUG && $to_trace; + return 0 if $a->start != $b->start || $a->end != $b->end; + } + return 1; + } + + sub set_equivalent_to { + # Set $self equivalent to the parameter table. + # The required Related => 'x' parameter is a boolean indicating + # whether these tables are related or not. If related, $other becomes + # the 'parent' of $self; if unrelated it becomes the 'leader' + # + # Related tables share all characteristics except names; equivalents + # not quite so many. + # If they are related, one must be a perl extension. This is because + # we can't guarantee that Unicode won't change one or the other in a + # later release even if they are idential now. + + my $self = shift; + my $other = shift; + + my %args = @_; + my $related = delete $args{'Related'}; + + Carp::carp_extra_args(\%args) if main::DEBUG && %args; + + return if ! defined $other; # Keep on going; happens in some early + # Unicode releases. + + if (! defined $related) { + Carp::my_carp_bug("set_equivalent_to must have 'Related => [01] parameter. Assuming $self is not related to $other"); + $related = 0; + } + + # If already are equivalent, no need to re-do it; if subroutine + # returns null, it found an error, also do nothing + my $are_equivalent = $self->is_equivalent_to($other); + return if ! defined $are_equivalent || $are_equivalent; + + my $current_leader = ($related) + ? $parent{main::objaddr $self} + : $leader{main::objaddr $self}; + + if ($related && + ! $other->perl_extension + && ! $current_leader->perl_extension) + { + Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other"); + $related = 0; + } + + my $leader = main::objaddr $current_leader; + my $other_addr = main::objaddr $other; + + # Any tables that are equivalent to or children of this table must now + # instead be equivalent to or (children) to the new leader (parent), + # still equivalent. The equivalency includes their matches_all info, + # and for related tables, their status + # All related tables are of necessity equivalent, but the converse + # isn't necessarily true + my $status = $other->status; + my $status_info = $other->status_info; + my $matches_all = $matches_all{other_addr}; + foreach my $table ($current_leader, @{$equivalents{$leader}}) { + next if $table == $other; + trace "setting $other to be the leader of $table, status=$status" if main::DEBUG && $to_trace; + + my $table_addr = main::objaddr $table; + $leader{$table_addr} = $other; + $matches_all{$table_addr} = $matches_all; + $self->_set_range_list($other->_range_list); + push @{$equivalents{$other_addr}}, $table; + if ($related) { + $parent{$table_addr} = $other; + push @{$children{$other_addr}}, $table; + $table->set_status($status, $status_info); + } + } + + # Now that we've declared these to be equivalent, any changes to one + # of the tables would invalidate that equivalency. + $self->lock; + $other->lock; + return; + } + + sub add_range { # Add a range to the list for this table. + my $self = shift; + # Rest of parameters passed on + + return if $self->carp_if_locked; + return $self->_range_list->add_range(@_); + } + + sub pre_body { # Does nothing for match tables. + return + } + + sub append_to_body { # Does nothing for match tables. + return + } + + sub write { + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + return $self->SUPER::write(2); # 2 tab stops + } + + sub set_final_comment { + # This creates a comment for the file that is to hold the match table + # $self. It is somewhat convoluted to make the English read nicely, + # but, heh, it's just a comment. + # This should be called only with the leader match table of all the + # ones that share the same file. It lists all such tables, ordered so + # that related ones are together. + + my $leader = shift; # Should only be called on the leader table of + # an equivalent group + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $leader; + + if ($leader{$addr} != $leader) { + Carp::my_carp_bug(<<END +set_final_comment() must be called on a leader table, which $leader is not. +It is equivalent to $leader{$addr}. No comment created +END + ); + return; + } + + # Get the number of code points matched by each of the tables in this + # file, and add underscores for clarity. + my $count = $leader->count; + my $string_count = main::clarify_number($count); + + my $loose_count = 0; # how many aliases loosely matched + my $compound_name = ""; # ? Are any names compound?, and if so, an + # example + my $properties_with_compound_names = 0; # count of these + + + my %flags; # The status flags used in the file + my $total_entries = 0; # number of entries written in the comment + my $matches_comment = ""; # The portion of the comment about the + # \p{}'s + my @global_comments; # List of all the tables' comments that are + # there before this routine was called. + + # Get list of all the parent tables that are equivalent to this one + # (including itself). + my @parents = grep { $parent{main::objaddr $_} == $_ } + main::uniques($leader, @{$equivalents{$addr}}); + my $has_unrelated = (@parents >= 2); # boolean, ? are there unrelated + # tables + + for my $parent (@parents) { + + my $property = $parent->property; + + # Special case 'N' tables in properties with two match tables when + # the other is a 'Y' one. These are likely to be binary tables, + # but not necessarily. In either case, \P{} will match the + # complement of \p{}, and so if something is a synonym of \p, the + # complement of that something will be the synonym of \P. This + # would be true of any property with just two match tables, not + # just those whose values are Y and N; but that would require a + # little extra work, and there are none such so far in Unicode. + my $perl_p = 'p'; # which is it? \p{} or \P{} + my @yes_perl_synonyms; # list of any synonyms for the 'Y' table + + if (scalar $property->tables == 2 + && $parent == $property->table('N') + && defined (my $yes = $property->table('Y'))) + { + my $yes_addr = main::objaddr $yes; + @yes_perl_synonyms + = grep { $_->property == $perl } + main::uniques($yes, + $parent{$yes_addr}, + $parent{$yes_addr}->children); + + # But these synonyms are \P{} ,not \p{} + $perl_p = 'P'; + } + + my @description; # Will hold the table description + my @note; # Will hold the table notes. + my @conflicting; # Will hold the table conflicts. + + # Look at the parent, any yes synonyms, and all the children + for my $table ($parent, + @yes_perl_synonyms, + @{$children{main::objaddr $parent}}) + { + my $table_addr = main::objaddr $table; + my $table_property = $table->property; + + # Tables are separated by a blank line to create a grouping. + $matches_comment .= "\n" if $matches_comment; + + # The table is named based on the property and value + # combination it is for, like script=greek. But there may be + # a number of synonyms for each side, like 'sc' for 'script', + # and 'grek' for 'greek'. Any combination of these is a valid + # name for this table. In this case, there are three more, + # 'sc=grek', 'sc=greek', and 'script='grek'. Rather than + # listing all possible combinations in the comment, we make + # sure that each synonym occurs at least once, and add + # commentary that the other combinations are possible. + my @property_aliases = $table_property->aliases; + my @table_aliases = $table->aliases; + + Carp::my_carp_bug("$table doesn't have any names. Proceeding anyway.") unless @table_aliases; + + # The alias lists above are already ordered in the order we + # want to output them. To ensure that each synonym is listed, + # we must use the max of the two numbers. + my $listed_combos = main::max(scalar @table_aliases, + scalar @property_aliases); + trace "$listed_combos, tables=", scalar @table_aliases, "; names=", scalar @property_aliases if main::DEBUG; + + my $property_had_compound_name = 0; + + for my $i (0 .. $listed_combos - 1) { + $total_entries++; + + # The current alias for the property is the next one on + # the list, or if beyond the end, start over. Similarly + # for the table (\p{prop=table}) + my $property_alias = $property_aliases + [$i % @property_aliases]->name; + my $table_alias_object = $table_aliases + [$i % @table_aliases]; + my $table_alias = $table_alias_object->name; + my $loose_match = $table_alias_object->loose_match; + + if ($table_alias !~ /\D/) { # Clarify large numbers. + $table_alias = main::clarify_number($table_alias) + } + + # Add a comment for this alias combination + my $current_match_comment; + if ($table_property == $perl) { + $current_match_comment = "\\$perl_p" + . "{$table_alias}"; + } + else { + $current_match_comment + = "\\p{$property_alias=$table_alias}"; + $property_had_compound_name = 1; + } + + # Flag any abnormal status for this table. + my $flag = $property->status + || $table->status + || $table_alias_object->status; + $flags{$flag} = $status_past_participles{$flag} if $flag; + + $loose_count++; + + # Pretty up the comment. Note the \b; it says don't make + # this line a continuation. + $matches_comment .= sprintf("\b%-1s%-s%s\n", + $flag, + " " x 7, + $current_match_comment); + } # End of generating the entries for this table. + + # Save these for output after this group of related tables. + push @description, $table->description; + push @note, $table->note; + push @conflicting, $table->conflicting; + + # Compute an alternate compound name using the final property + # synonym and the first table synonym with a colon instead of + # the equal sign used elsewhere. + if ($property_had_compound_name) { + $properties_with_compound_names ++; + if (! $compound_name || @property_aliases > 1) { + $compound_name = $property_aliases[-1]->name + . ': ' + . $table_aliases[0]->name; + } + } + } # End of looping through all children of this table + + # Here have assembled in $matches_comment all the related tables + # to the current parent (preceded by the same info for all the + # previous parents). Put out information that applies to all of + # the current family. + if (@conflicting) { + + # But output the conflicting information now, as it applies to + # just this table. + my $conflicting = join ", ", @conflicting; + if ($conflicting) { + $matches_comment .= <<END; + + Note that contrary to what you might expect, the above is NOT the same as +END + $matches_comment .= "any of: " if @conflicting > 1; + $matches_comment .= "$conflicting\n"; + } + } + if (@description) { + $matches_comment .= "\n Meaning: " + . join('; ', @description) + . "\n"; + } + if (@note) { + $matches_comment .= "\n Note: " + . join("\n ", @note) + . "\n"; + } + } # End of looping through all tables + + + my $code_points; + my $match; + my $any_of_these; + if ($count == 1) { + $match = 'matches'; + $code_points = 'single code point'; + } + else { + $match = 'match'; + $code_points = "$string_count code points"; + } + + my $synonyms; + my $entries; + if ($total_entries <= 1) { + $synonyms = ""; + $entries = 'entry'; + $any_of_these = 'this' + } + else { + $synonyms = " any of the following regular expression constructs"; + $entries = 'entries'; + $any_of_these = 'any of these' + } + + my $comment = ""; + if ($has_unrelated) { + $comment .= <<END; +This file is for tables that are not necessarily related: To conserve +resources, every table that matches the identical set of code points in this +version of Unicode uses this file. Each one is listed in a separate group +below. It could be that the tables will match the same set of code points in +other Unicode releases, or it could be purely coincidence that they happen to +be the same in Unicode $string_version, and hence may not in other versions. + +END + } + + if (%flags) { + foreach my $flag (sort keys %flags) { + $comment .= <<END; +'$flag' below means that this form is $flags{$flag}. Consult $pod_file.pod +END + } + $comment .= "\n"; + } + + $comment .= <<END; +This file returns the $code_points in Unicode Version $string_version that +$match$synonyms: + +$matches_comment +$pod_file.pod should be consulted for the rules on using $any_of_these, +including if adding or subtracting white space, underscore, and hyphen +characters matters or doesn't matter, and other permissible syntactic +variants. Upper/lower case distinctions never matter. +END + + if ($compound_name) { + $comment .= <<END; + +A colon can be substituted for the equals sign, and +END + if ($properties_with_compound_names > 1) { + $comment .= <<END; +within each group above, +END + } + $compound_name = sprintf("%-8s\\p{%s}", " ", $compound_name); + + # Note the \b below, it says don't make that line a continuation. + $comment .= <<END; +anything to the left of the equals (or colon) can be combined with anything to +the right. Thus, for example, +$compound_name +\bis also valid. +END + } + + # And append any comment(s) from the actual tables. They are all + # gathered here, so may not read all that well. + $comment .= "\n" . join "\n\n", @global_comments if @global_comments; + + if ($count) { # The format differs if no code points, and needs no + # explanation in that case + $comment.= <<END; + +The format of the lines of this file is: +END + $comment.= <<END; +START\\tSTOP\\twhere START is the starting code point of the range, in hex; +STOP is the ending point, or if omitted, the range has just one code point. +END + if ($output_range_counts) { + $comment .= <<END; +Numbers in comments in [brackets] indicate how many code points are in the +range. +END + } + } + + $leader->set_comment(main::join_lines($comment)); + return; + } + + # Accessors for the underlying list + for my $sub qw( + get_valid_code_point + get_invalid_code_point + ) { - ## Need to ensure that all decomposition characters do not have - ## a %HexCodeToComb in %AboveCombClasses. - my $want = 1; - for my $deco_hexcode (split / /, $CodeToDeco{$code}) + no strict "refs"; + *$sub = sub { + use strict "refs"; + my $self = shift; + + return $self->_range_list->$sub(@_); + } + } +} # End closure for Match_Table + +package Property; + +# The Property class represents a Unicode property, or the $perl +# pseudo-property. It contains a map table initialized empty at construction +# time, and for properties accessible through regular expressions, various +# match tables, created through the add_match_table() method, and referenced +# by the table('NAME') or tables() methods, the latter returning a list of all +# of the match tables. Otherwise table operations implicitly are for the map +# table. +# +# Most of the data in the property is actually about its map table, so it +# mostly just uses that table's accessors for most methods. The two could +# have been combined into one object, but for clarity because of their +# differing semantics, they have been kept separate. It could be argued that +# the 'file' and 'directory' fields should be kept with the map table. +# +# Each property has a type. This can be set in the constructor, or in the +# set_type accessor, but mostly it is figured out by the data. Every property +# starts with unknown type, overridden by a parameter to the constructor, or +# as match tables are added, or ranges added to the map table, the data is +# inspected, and the type changed. After the table is mostly or entirely +# filled, compute_type() should be called to finalize they analysis. +# +# There are very few operations defined. One can safely remove a range from +# the map table, and property_add_or_replace_non_nulls() adds the maps from another +# table to this one, replacing any in the intersection of the two. + +sub standardize { return main::standardize($_[0]); } +sub trace { return main::trace(@_) if main::DEBUG && $to_trace } + +{ # Closure + + # This hash will contain as keys, all the aliases of all properties, and + # as values, pointers to their respective property objects. This allows + # quick look-up of a property from any of its names. + my %alias_to_property_of; + + sub dump_alias_to_property_of { + # For debugging + + print "\n", main::simple_dumper (\%alias_to_property_of), "\n"; + return; + } + + sub property_ref { + # This is a package subroutine, not called as a method. + # If the single parameter is a literal '*' it returns a list of all + # defined properties. + # Otherwise, the single parameter is a name, and it returns a pointer + # to the corresponding property object, or undef if none. + # + # Properties can have several different names. The 'standard' form of + # each of them is stored in %alias_to_property_of as they are defined. + # But it's possible that this subroutine will be called with some + # variant, so if the initial lookup fails, it is repeated with the + # standarized form of the input name. If found, besides returning the + # result, the input name is added to the list so future calls won't + # have to do the conversion again. + + my $name = shift; + + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + if (! defined $name) { + Carp::my_carp_bug("Undefined input property. No action taken."); + return; + } + + return main::uniques(values %alias_to_property_of) if $name eq '*'; + + # Return cached result if have it. + my $result = $alias_to_property_of{$name}; + return $result if defined $result; + + # Convert the input to standard form. + my $standard_name = standardize($name); + + $result = $alias_to_property_of{$standard_name}; + return unless defined $result; # Don't cache undefs + + # Cache the result before returning it. + $alias_to_property_of{$name} = $result; + return $result; + } + + + main::setup_package(); + + my %map; + # A pointer to the map table object for this property + main::set_access('map', \%map); + + my %full_name; + # The property's full name. This is a duplicate of the copy kept in the + # map table, but is needed because stringify needs it during + # construction of the map table, and then would have a chicken before egg + # problem. + main::set_access('full_name', \%full_name, 'r'); + + my %table_ref; + # This hash will contain as keys, all the aliases of any match tables + # attached to this property, and as values, the pointers to their + # respective tables. This allows quick look-up of a table from any of its + # names. + main::set_access('table_ref', \%table_ref); + + my %type; + # The type of the property, $ENUM, $BINARY, etc + main::set_access('type', \%type, 'r'); + + my %file; + # The filename where the map table will go (if actually written). + # Normally defaulted, but can be overridden. + main::set_access('file', \%file, 'r', 's'); + + my %directory; + # The directory where the map table will go (if actually written). + # Normally defaulted, but can be overridden. + main::set_access('directory', \%directory, 's'); + + my %pseudo_map_type; + # This is used to affect the calculation of the map types for all the + # ranges in the table. It should be set to one of the values that signify + # to alter the calculation. + main::set_access('pseudo_map_type', \%pseudo_map_type, 'r'); + + my %has_only_code_point_maps; + # A boolean used to help in computing the type of data in the map table. + main::set_access('has_only_code_point_maps', \%has_only_code_point_maps); + + my %unique_maps; + # A list of the first few distinct mappings this property has. This is + # used to disambiguate between binary and enum property types, so don't + # have to keep more than three. + main::set_access('unique_maps', \%unique_maps); + + sub new { + # The only required parameter is the positionally first, name. All + # other parameters are key => value pairs. See the documentation just + # above for the meanings of the ones not passed directly on to the map + # table constructor. + + my $class = shift; + my $name = shift || ""; + + my $self = property_ref($name); + if (defined $self) { + my $options_string = join ", ", @_; + $options_string = ". Ignoring options $options_string" if $options_string; + Carp::my_carp("$self is already in use. Using existing one$options_string;"); + return $self; + } + + my %args = @_; + + $self = bless \do { my $anonymous_scalar }, $class; + my $addr = main::objaddr $self; + + $directory{$addr} = delete $args{'Directory'}; + $file{$addr} = delete $args{'File'}; + $full_name{$addr} = delete $args{'Full_Name'} || $name; + $type{$addr} = delete $args{'Type'} || $UNKNOWN; + $pseudo_map_type{$addr} = delete $args{'Map_Type'}; + # Rest of parameters passed on. + + $has_only_code_point_maps{$addr} = 1; + $table_ref{$addr} = { }; + $unique_maps{$addr} = { }; + + $map{$addr} = Map_Table->new($name, + Full_Name => $full_name{$addr}, + _Alias_Hash => \%alias_to_property_of, + _Property => $self, + %args); + return $self; + } + + # See this program's beginning comment block about overloading the copy + # constructor. Few operations are defined on properties, but a couple are + # useful. It is safe to take the inverse of a property, and to remove a + # single code point from it. + use overload + fallback => 0, + qw("") => "_operator_stringify", + "." => \&main::_operator_dot, + '==' => \&main::_operator_equal, + '!=' => \&main::_operator_not_equal, + '=' => sub { return shift }, + '-=' => "_minus_and_equal", + ; + + sub _operator_stringify { + return "Property '" . shift->full_name . "'"; + } + + sub _minus_and_equal { + # Remove a single code point from the map table of a property. + + my $self = shift; + my $other = shift; + my $reversed = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + if (ref $other) { + Carp::my_carp_bug("Can't cope with a " + . ref($other) + . " argument to '-='. Subtraction ignored."); + return $self; + } + elsif ($reversed) { # Shouldnt happen in a -=, but just in case + Carp::my_carp_bug("Can't cope with a " + . __PACKAGE__ + . " being the first parameter in a '-='. Subtraction ignored."); + return $self; + } + else { + $map{main::objaddr $self}->delete_range($other, $other); + } + return $self; + } + + sub add_match_table { + # Add a new match table for this property, with name given by the + # parameter. It returns a pointer to the table. + + my $self = shift; + my $name = shift; + my %args = @_; + + my $addr = main::objaddr $self; + + my $table = $table_ref{$addr}{$name}; + my $standard_name = main::standardize($name); + if (defined $table + || (defined ($table = $table_ref{$addr}{$standard_name}))) { - if (exists $_Above_HexCodes{$deco_hexcode}) { - ## one of the decmposition chars has an ABOVE combination - ## class, so we're not interested in this one - $want = 0; - last; + Carp::my_carp("Table '$name' in $self is already in use. Using existing one"); + $table_ref{$addr}{$name} = $table; + return $table; + } + else { + + # See if this is a perl extension, if not passed in. + my $perl_extension = delete $args{'Perl_Extension'}; + $perl_extension + = $self->perl_extension if ! defined $perl_extension; + + $table = Match_Table->new( + Name => $name, + Perl_Extension => $perl_extension, + _Alias_Hash => $table_ref{$addr}, + _Property => $self, + + # gets property's status by default + Status => $self->status, + _Status_Info => $self->status_info, + %args, + Internal_Only_Warning => 1); # Override any + # input param + return unless defined $table; + } + + # Save the names for quick look up + $table_ref{$addr}{$standard_name} = $table; + $table_ref{$addr}{$name} = $table; + + # Perhaps we can figure out the type of this property based on the + # fact of adding this match table. First, string properties don't + # have match tables; second, a binary property can't have 3 match + # tables + if ($type{$addr} == $UNKNOWN) { + $type{$addr} = $NON_STRING; + } + elsif ($type{$addr} == $STRING) { + Carp::my_carp("$self Added a match table '$name' to a string property '$self'. Changed it to a non-string property. Bad News."); + $type{$addr} = $NON_STRING; + } + elsif ($type{$addr} != $ENUM) { + if (scalar main::uniques(values %{$table_ref{$addr}}) > 2 + && $type{$addr} == $BINARY) + { + Carp::my_carp("$self now has more than 2 tables (with the addition of '$name'), and so is no longer binary. Changing its type to 'enum'. Bad News."); + $type{$addr} = $ENUM; } } - if ($want) { - $CanonCDIJ->Append($code); + + return $table; + } + + sub table { + # Return a pointer to the match table (with name given by the + # parameter) associated with this property; undef if none. + + my $self = shift; + my $name = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + return $table_ref{$addr}{$name} if defined $table_ref{$addr}{$name}; + + # If quick look-up failed, try again using the standard form of the + # input name. If that succeeds, cache the result before returning so + # won't have to standardize this input name again. + my $standard_name = main::standardize($name); + return unless defined $table_ref{$addr}{$standard_name}; + + $table_ref{$addr}{$name} = $table_ref{$addr}{$standard_name}; + return $table_ref{$addr}{$name}; + } + + sub tables { + # Return a list of pointers to all the match tables attached to this + # property + + return main::uniques(values %{$table_ref{main::objaddr shift}}); + } + + sub directory { + # Returns the directory the map table for this property should be + # output in. If a specific directory has been specified, that has + # priority; 'undef' is returned if the type isn't defined; + # or $map_directory for everything else. + + my $addr = main::objaddr shift; + + return $directory{$addr} if defined $directory{$addr}; + return undef if $type{$addr} == $UNKNOWN; + return $map_directory; + } + + sub swash_name { + # Return the name that is used to both: + # 1) Name the file that the map table is written to. + # 2) The name of swash related stuff inside that file. + # The reason for this is that the Perl core historically has used + # certain names that aren't the same as the Unicode property names. + # To continue using these, $file is hard-coded in this file for those, + # but otherwise the standard name is used. This is different from the + # external_name, so that the rest of the files, like in lib can use + # the standard name always, without regard to historical precedent. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr $self; + + return $file{$addr} if defined $file{$addr}; + return $map{$addr}->external_name; + } + + sub to_create_match_tables { + # Returns a boolean as to whether or not match tables should be + # created for this property. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # The whole point of this pseudo property is match tables. + return 1 if $self == $perl; + + my $addr = main::objaddr $self; + + # Don't generate tables of code points that match the property values + # of a string property. Such a list would most likely have many + # property values, each with just one or very few code points mapping + # to it. + return 0 if $type{$addr} == $STRING; + + # Don't generate anything for unimplemented properties. + return 0 if grep { $self->complete_name eq $_ } + @unimplemented_properties; + # Otherwise, do. + return 1; + } + + sub property_add_or_replace_non_nulls { + # This adds the mappings in the property $other to $self. Non-null + # mappings from $other override those in $self. It essentially merges + # the two properties, with the second having priority except for null + # mappings. + + my $self = shift; + my $other = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + if (! $other->isa(__PACKAGE__)) { + Carp::my_carp_bug("$other should be a " + . __PACKAGE__ + . ". Not a '" + . ref($other) + . "'. Not added;"); + return; + } + + return $map{main::objaddr $self}-> + map_add_or_replace_non_nulls($map{main::objaddr $other}); + } + + sub set_type { + # Set the type of the property. Mostly this is figured out by the + # data in the table. But this is used to set it explicitly. The + # reason it is not a standard accessor is that when setting a binary + # property, we need to make sure that all the true/false aliases are + # present, as they were omitted in early Unicode releases. + + my $self = shift; + my $type = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + if ($type != $ENUM && $type != $BINARY && $type != $STRING) { + Carp::my_carp("Unrecognized type '$type'. Type not set"); + return; + } + + $type{main::objaddr $self} = $type; + return if $type != $BINARY; + + my $yes = $self->table('Y'); + $yes = $self->table('Yes') if ! defined $yes; + $yes = $self->add_match_table('Y') if ! defined $yes; + $yes->add_alias('Yes'); + $yes->add_alias('T'); + $yes->add_alias('True'); + + my $no = $self->table('N'); + $no = $self->table('No') if ! defined $no; + $no = $self->add_match_table('N') if ! defined $no; + $no->add_alias('No'); + $no->add_alias('F'); + $no->add_alias('False'); + return; + } + + sub add_map { + # Add a map to the property's map table. This also keeps + # track of the maps so that the property type can be determined from + # its data. + + my $self = shift; + my $start = shift; # First code point in range + my $end = shift; # Final code point in range + my $map = shift; # What the range maps to. + # Rest of parameters passed on. + + my $addr = main::objaddr $self; + + # If haven't the type of the property, gather information to figure it + # out. + if ($type{$addr} == $UNKNOWN) { + + # If the map contains an interior blank or dash, or most other + # nonword characters, it will be a string property. This + # heuristic may actually miss some string properties. If so, they + # may need to have explicit set_types called for them. This + # happens in the Unihan properties. + if ($map =~ / (?<= . ) [ -] (?= . ) /x + || $map =~ / [^\w.\/\ -] /x) + { + $self->set_type($STRING); + + # $unique_maps is used for disambiguating between ENUM and + # BINARY later; since we know the property is not going to be + # one of those, no point in keeping the data around + undef $unique_maps{$addr}; + } + else { + + # Not necessarily a string. The final decision has to be + # deferred until all the data are in. We keep track of if all + # the values are code points for that eventual decision. + $has_only_code_point_maps{$addr} &= + $map =~ / ^ $code_point_re $/x; + + # For the purposes of disambiguating between binary and other + # enumerations at the end, we keep track of the first three + # distinct property values. Once we get to three, we know + # it's not going to be binary, so no need to track more. + if (scalar keys %{$unique_maps{$addr}} < 3) { + $unique_maps{$addr}{main::standardize($map)} = 1; + } + } } + + # Add the mapping by calling our map table's method + return $map{$addr}->add_map($start, $end, $map, @_); } + sub compute_type { + # Compute the type of the property: $ENUM, $STRING, or $BINARY. This + # should be called after the property is mostly filled with its maps. + # We have been keeping track of what the property values have been, + # and now have the necessary information to figure out the type. + + my $self = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $addr = main::objaddr($self); + my $type = $type{$addr}; - ## - ## Now dump the files. - ## - $Name->Write("Name.pl"); + # If already have figured these out, no need to do so again, but we do + # a double check on ENUMS to make sure that a string property hasn't + # improperly been classified as an ENUM, so continue on with those. + return if $type == $STRING || $type == $BINARY; + # If every map is to a code point, is a string property. + if ($type == $UNKNOWN + && ($has_only_code_point_maps{$addr} + || (defined $map{$addr}->default_map + && $map{$addr}->default_map eq ""))) + { + $self->set_type($STRING); + } + else { + + # Otherwise, it is to some sort of enumeration. (The case where + # it is a Unicode miscellaneous property, and treated like a + # string in this program is handled in add_map()). Distinguish + # between binary and some other enumeration type. Of course, if + # there are more than two values, it's not binary. But more + # subtle is the test that the default mapping is defined means it + # isn't binary. This in fact may change in the future if Unicode + # changes the way its data is structured. But so far, no binary + # properties ever have @missing lines for them, so the default map + # isn't defined for them. The few properties that are two-valued + # and aren't considered binary have the default map defined + # starting in Unicode 5.0, when the @missing lines appeared; and + # this program has special code to put in a default map for them + # for earlier than 5.0 releases. + if ($type == $ENUM + || scalar keys %{$unique_maps{$addr}} > 2 + || defined $self->default_map) + { + my $tables = $self->tables; + my $count = $self->count; + if ($verbosity && $count > 500 && $tables/$count > .1) { + Carp::my_carp_bug("It appears that $self should be a \$STRING property, not an \$ENUM because it has too many match tables: $count\n"); + } + $self->set_type($ENUM); + } + else { + $self->set_type($BINARY); + } + } + undef $unique_maps{$addr}; # Garbage collect + return; + } + + # Most of the accessors for a property actually apply to its map table. + # Setup up accessor functions for those, referring to %map + for my $sub qw( + add_alias + add_anomalous_entry + add_comment + add_conflicting + add_description + add_duplicate + add_note + aliases + comment + complete_name + core_access + count + default_map + delete_range + description + each_range + external_name + file_path + format + initialize + inverse_list + is_empty + name + note + perl_extension + property + range_count + ranges + range_size_1 + reset_each_range + set_comment + set_core_access + set_default_map + set_file_path + set_final_comment + set_range_size_1 + set_status + set_to_output_map + short_name + status + status_info + to_output_map + value_of + write + ) + # 'property' above is for symmetry, so that one can take + # the property of a property and get itself, and so don't + # have to distinguish between properties and tables in + # calling code { - my @PVA = $HEADER; - foreach my $name (qw (PropertyAlias PA_reverse PropValueAlias - PVA_reverse PVA_abbr_map)) { - # Should I really jump through typeglob hoops just to avoid a - # symbolic reference? (%{"utf8::$name}) - push @PVA, "\n", "\%utf8::$name = (\n", - simple_dumper (%{$utf8::{$name}}), ");\n"; - } - push @PVA, "1;\n"; - WriteIfChanged("PVA.pl", @PVA); + no strict "refs"; + *$sub = sub { + use strict "refs"; + my $self = shift; + return $map{main::objaddr $self}->$sub(@_); + } } - # $Bidi->Write("Bidirectional.pl"); - for (keys %Bidi) { - $Bidi{$_}->Write( - ["lib","bc","$_.pl"], - "BidiClass category '$PropValueAlias{bc}{$_}'" - ); + +} # End closure + +package main; + +sub join_lines($) { + # Returns lines of the input joined together, so that they can be folded + # properly. + # This causes continuation lines to be joined together into one long line + # for folding. A continuation line is any line that doesn't begin with a + # space or "\b" (the latter is stripped from the output). This is so + # lines can be be in a HERE document so as to fit nicely in the terminal + # width, but be joined together in one long line, and then folded with + # indents, '#' prefixes, etc, properly handled. + # A blank separates the joined lines except if there is a break; an extra + # blank is inserted after a period ending a line. + + # Intialize the return with the first line. + my ($return, @lines) = split "\n", shift; + + # If the first line is null, it was an empty line, add the \n back in + $return = "\n" if $return eq ""; + + # Now join the remainder of the physical lines. + for my $line (@lines) { + + # An empty line means wanted a blank line, so add two \n's to get that + # effect, and go to the next line. + if (length $line == 0) { + $return .= "\n\n"; + next; + } + + # Look at the last character of what we have so far. + my $previous_char = substr($return, -1, 1); + + # And at the next char to be output. + my $next_char = substr($line, 0, 1); + + if ($previous_char ne "\n") { + + # Here didn't end wth a nl. If the next char a blank or \b, it + # means that here there is a break anyway. So add a nl to the + # output. + if ($next_char eq " " || $next_char eq "\b") { + $previous_char = "\n"; + $return .= $previous_char; + } + + # Add an extra space after periods. + $return .= " " if $previous_char eq '.'; + } + + # Here $previous_char is still the latest character to be output. If + # it isn't a nl, it means that the next line is to be a continuation + # line, with a blank inserted between them. + $return .= " " if $previous_char ne "\n"; + + # Get rid of any \b + substr($line, 0, 1) = "" if $next_char eq "\b"; + + # And append this next line. + $return .= $line; } - $Comb->Write("CombiningClass.pl"); - for (keys %{ $PropValueAlias{ccc} }) { - my ($code, $name) = @{ $PropValueAlias{ccc}{$_} }; - (my $c = Table->New())->Append($code); - $c->Write( - ["lib","ccc","$_.pl"], - "CombiningClass category '$name'" - ); + return $return; +} + +sub simple_fold($;$$$) { + # Returns a string of the input (string or an array of strings) folded + # into multiple-lines each of no more than $MAX_LINE_WIDTH characters plus + # a \n + # This is tailored for the kind of text written by this program, + # especially the pod file, which can have very long names with + # underscores in the middle, or words like AbcDefgHij.... We allow + # breaking in the middle of such constructs if the line won't fit + # otherwise. The break in such cases will come either just after an + # underscore, or just before one of the Capital letters. + + local $to_trace = 0 if main::DEBUG; + + my $line = shift; + my $prefix = shift; # Optional string to prepend to each output + # line + $prefix = "" unless defined $prefix; + + my $hanging_indent = shift; # Optional number of spaces to indent + # continuation lines + $hanging_indent = 0 unless $hanging_indent; + + my $right_margin = shift; # Optional number of spaces to narrow the + # total width by. + $right_margin = 0 unless defined $right_margin; + + # Call carp with the 'nofold' option to avoid it from trying to call us + # recursively + Carp::carp_extra_args(\@_, 'nofold') if main::DEBUG && @_; + + # The space available doesn't include what's automatically prepended + # to each line, or what's reserved on the right. + my $max = $MAX_LINE_WIDTH - length($prefix) - $right_margin; + # XXX Instead of using the 'nofold' perhaps better to look up the stack + + if (DEBUG && $hanging_indent >= $max) { + Carp::my_carp("Too large a hanging indent ($hanging_indent); must be < $max. Using 0", 'nofold'); + $hanging_indent = 0; } - $Deco->Write("Decomposition.pl"); - for (keys %DC) { - $DC{$_}->Write( - ["lib","dt","$_.pl"], - "DecompositionType category '$PropValueAlias{dt}{$_}'" - ); + # First, split into the current physical lines. + my @line; + if (ref $line) { # Better be an array, because not bothering to + # test + foreach my $line (@{$line}) { + push @line, split /\n/, $line; + } } + else { + @line = split /\n/, $line; + } + + #local $to_trace = 1 if main::DEBUG; + trace "", join(" ", @line), "\n" if main::DEBUG && $to_trace; + + # Look at each current physical line. + for (my $i = 0; $i < @line; $i++) { + Carp::my_carp("Tabs don't work well.", 'nofold') if $line[$i] =~ /\t/; + #local $to_trace = 1 if main::DEBUG; + trace "i=$i: $line[$i]\n" if main::DEBUG && $to_trace; + + # Remove prefix, because will be added back anyway, don't want + # doubled prefix + $line[$i] =~ s/^$prefix//; + + # Remove trailing space + $line[$i] =~ s/\s+\Z//; + + # If the line is too long, fold it. + if (length $line[$i] > $max) { + my $remainder; + + # Here needs to fold. Save the leading space in the line for + # later. + $line[$i] =~ /^ ( \s* )/x; + my $leading_space = $1; + trace "line length", length $line[$i], "; lead length", length($leading_space) if main::DEBUG && $to_trace; + + # If character at final permissible position is white space, + # fold there, which will delete that white space + if (substr($line[$i], $max - 1, 1) =~ /\s/) { + $remainder = substr($line[$i], $max); + $line[$i] = substr($line[$i], 0, $max - 1); + } + else { + + # Otherwise fold at an acceptable break char closest to + # the max length. Look at just the maximal initial + # segment of the line + my $segment = substr($line[$i], 0, $max - 1); + if ($segment =~ + /^ ( .{$hanging_indent} # Don't look before the + # indent. + \ * # Don't look in leading + # blanks past the indent + [^ ] .* # Find the right-most + (?: # acceptable break: + [ \s = ] # space or equal + | - (?! [.0-9] ) # or non-unary minus. + ) # $1 includes the character + )/x) + { + # Split into the initial part that fits, and remaining + # part of the input + $remainder = substr($line[$i], length $1); + $line[$i] = $1; + trace $line[$i] if DEBUG && $to_trace; + trace $remainder if DEBUG && $to_trace; + } + + # If didn't find a good breaking spot, see if there is a + # not-so-good breaking spot. These are just after + # underscores or where the case changes from lower to + # upper. Use \a as a soft hyphen, but give up + # and don't break the line if there is actually a \a + # already in the input. We use an ascii character for the + # soft-hyphen to avoid any attempt by miniperl to try to + # access the files that this program is creating. + elsif ($segment !~ /\a/ + && ($segment =~ s/_/_\a/g + || $segment =~ s/ ( [a-z] ) (?= [A-Z] )/$1\a/xg)) + { + # Here were able to find at least one place to insert + # our substitute soft hyphen. Find the right-most one + # and replace it by a real hyphen. + trace $segment if DEBUG && $to_trace; + substr($segment, + rindex($segment, "\a"), + 1) = '-'; + + # Then remove the soft hyphen substitutes. + $segment =~ s/\a//g; + trace $segment if DEBUG && $to_trace; + + # And split into the initial part that fits, and + # remainder of the line + my $pos = rindex($segment, '-'); + $remainder = substr($line[$i], $pos); + trace $remainder if DEBUG && $to_trace; + $line[$i] = substr($segment, 0, $pos + 1); + } + } + + # Here we know if we can fold or not. If we can, $remainder + # is what remains to be processed in the next iteration. + if (defined $remainder) { + trace "folded='$line[$i]'" if main::DEBUG && $to_trace; + + # Insert the folded remainder of the line as a new element + # of the array. (It may still be too long, but we will + # deal with that next time through the loop.) Omit any + # leading space in the remainder. + $remainder =~ s/^\s+//; + trace "remainder='$remainder'" if main::DEBUG && $to_trace; + + # But then indent by whichever is larger of: + # 1) the leading space on the input line; + # 2) the hanging indent. + # This preserves indentation in the original line. + my $lead = ($leading_space) + ? length $leading_space + : $hanging_indent; + $lead = max($lead, $hanging_indent); + splice @line, $i+1, 0, (" " x $lead) . $remainder; + } + } + + # Ready to output the line. Get rid of any trailing space + # And prefix by the required $prefix passed in. + $line[$i] =~ s/\s+$//; + $line[$i] = "$prefix$line[$i]\n"; + } # End of looping through all the lines. + + return join "", @line; +} + +sub property_ref { # Returns a reference to a property object. + return Property::property_ref(@_); +} - # $Number->Write("Number.pl"); - for (keys %Number) { - $Number{$_}->Write( - ["lib","nt","$_.pl"], - "NumericType category '$PropValueAlias{nt}{$_}'" - ); +sub force_unlink ($) { + my $filename = shift; + return unless file_exists($filename); + return if CORE::unlink($filename); + + # We might need write permission + chmod 0777, $filename; + CORE::unlink($filename) or Carp::my_carp("Couldn't unlink $filename. Proceeding anyway: $!"); + return; +} + +sub write ($\@) { + # Given a filename and a reference to an array of lines, write the lines + # to the file + # Filename can be given as an arrayref of directory names + + my $file = shift; + my $lines_ref = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + if (! defined $lines_ref) { + Carp::my_carp("Missing lines to write parameter for $file. Writing skipped;"); + return; } - # $General->Write("Category.pl"); + # Get into a single string if an array, and get rid of, in Unix terms, any + # leading '.' + $file= File::Spec->join(@$file) if ref $file eq 'ARRAY'; + $file = File::Spec->canonpath($file); + + # If has directories, make sure that they all exist + (undef, my $directories, undef) = File::Spec->splitpath($file); + File::Path::mkpath($directories) if $directories && ! -d $directories; - for my $to (sort keys %To) { - $To{$to}->Write(["To","$to.pl"]); + push @files_actually_output, $file; + + my $text; + if (@$lines_ref) { + $text = join "", @$lines_ref; + } + else { + $text = ""; + Carp::my_carp("Output file '$file' is empty; writing it anyway;"); } - for (keys %{ $PropValueAlias{gc} }) { - New_Alias(Is => $PropValueAlias{gc}{$_}, SameAs => $_, Fuzzy => 1); + force_unlink ($file); + + my $OUT; + if (not open $OUT, ">", $file) { + Carp::my_carp("can't open $file for output. Skipping this file: $!"); + return; } + print "$file written.\n" if $verbosity >= $VERBOSE; + + print $OUT $text; + close $OUT; + return; } -## -## Process LineBreak.txt -## -sub LineBreak_Txt() -{ - if (not open IN, "LineBreak.txt") { - die "$0: LineBreak.txt: $!\n"; + +sub Standardize($) { + # This converts the input name string into a standardized equivalent to + # use internally. + + my $name = shift; + unless (defined $name) { + Carp::my_carp_bug("Standardize() called with undef. Returning undef."); + return; } - my $Lbrk = Table->New(); - my %Lbrk; + # Remove any leading or trailing white space + $name =~ s/^\s+//g; + $name =~ s/\s+$//g; - while (<IN>) - { - next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/; + # Convert interior white space and hypens into underscores. + $name =~ s/ (?<= .) [ -]+ (.) /_$1/xg; + + # Capitalize the letter following an underscore, and convert a sequence of + # multiple underscores to a single one + $name =~ s/ (?<= .) _+ (.) /_\u$1/xg; + + # And capitalize the first letter, but not for the special cjk ones. + $name = ucfirst($name) unless $name =~ /^k[A-Z]/; + return $name; +} + +sub standardize ($) { + # Returns a lower-cased standardized name, without underscores. This form + # is chosen so that it can distinguish between any real versus superficial + # Unicode name differences. It relies on the fact that Unicode doesn't + # have interior underscores, white space, nor dashes in any + # stricter-matched name. It should not be used on Unicode code point + # names (the Name property), as they mostly, but not always follow these + # rules. + + my $name = Standardize(shift); + return if !defined $name; + + $name =~ s/ (?<= .) _ (?= . ) //xg; + return lc $name; +} + +{ # Closure + + my $indent_increment = " " x 2; + my %already_output; + + $main::simple_dumper_nesting = 0; + + sub simple_dumper { + # Like Simple Data::Dumper. Good enough for our needs. We can't use + # the real thing as we have to run under miniperl. + + # It is designed so that on input it is at the beginning of a line, + # and the final thing output in any call is a trailing ",\n". + + my $item = shift; + my $indent = shift; + $indent = "" if ! defined $indent; + + Carp::carp_extra_args(\@_) if main::DEBUG && @_; - my ($first, $last, $lbrk) = (hex($1), hex($2||""), $3); + # nesting level is localized, so that as the call stack pops, it goes + # back to the prior value. + local $main::simple_dumper_nesting = $main::simple_dumper_nesting; + undef %already_output if $main::simple_dumper_nesting == 0; + $main::simple_dumper_nesting++; + #print STDERR __LINE__, ": $main::simple_dumper_nesting: $indent$item\n"; - $Lbrk->Append($first, $lbrk); + Carp::carp_extra_args(\@_) if main::DEBUG && @_; - $Lbrk{$lbrk} ||= Table->New(); - $Lbrk{$lbrk}->Append($first); + # Determine the indent for recursive calls. + my $next_indent = $indent . $indent_increment; - if ($last) { - $Lbrk->Extend($last); - $Lbrk{$lbrk}->Extend($last); - } + my $output; + if (! ref $item) { + + # Dump of scalar: just output it in quotes if not a number. To do + # so we must escape certain characters, and therefore need to + # operate on a copy to avoid changing the original + my $copy = $item; + $copy = $UNDEF unless defined $copy; + + # Quote non-numbers (numbers also have optional leading '-' and + # fractions) + if ($copy eq "" || $copy !~ /^ -? \d+ ( \. \d+ )? $/x) { + + # Escape apostrophe and backslash + $copy =~ s/ ( ['\\] ) /\\$1/xg; + $copy = "'$copy'"; + } + $output = "$indent$copy,\n"; + } + else { + + # Keep track of cycles in the input, and refuse to infinitely loop + if (defined $already_output{main::objaddr $item}) { + return "${indent}ALREADY OUTPUT: $item\n"; + } + $already_output{main::objaddr $item} = $item; + + if (ref $item eq 'ARRAY') { + my $using_brackets; + $output = $indent; + if ($main::simple_dumper_nesting > 1) { + $output .= '['; + $using_brackets = 1; + } + else { + $using_brackets = 0; + } + + # If the array is empty, put the closing bracket on the same + # line. Otherwise, recursively add each array element + if (@$item == 0) { + $output .= " "; + } + else { + $output .= "\n"; + for (my $i = 0; $i < @$item; $i++) { + + # Indent array elements one level + $output .= &simple_dumper($item->[$i], $next_indent); + $output =~ s/\n$//; # Remove trailing nl so as to + $output .= " # [$i]\n"; # add a comment giving the + # array index + } + $output .= $indent; # Indent closing ']' to orig level + } + $output .= ']' if $using_brackets; + $output .= ",\n"; + } + elsif (ref $item eq 'HASH') { + my $is_first_line; + my $using_braces; + my $body_indent; + + # No surrounding braces at top level + $output .= $indent; + if ($main::simple_dumper_nesting > 1) { + $output .= "{\n"; + $is_first_line = 0; + $body_indent = $next_indent; + $next_indent .= $indent_increment; + $using_braces = 1; + } + else { + $is_first_line = 1; + $body_indent = $indent; + $using_braces = 0; + } + + # Output hashes sorted alphabetically instead of apparently + # random. Use caseless alphabetic sort + foreach my $key (sort { lc $a cmp lc $b } keys %$item) + { + if ($is_first_line) { + $is_first_line = 0; + } + else { + $output .= "$body_indent"; + } + + # The key must be a scalar, but this recursive call quotes + # it + $output .= &simple_dumper($key); + + # And change the trailing comma and nl to the hash fat + # comma for clarity, and so the value can be on the same + # line + $output =~ s/,\n$/ => /; + + # Recursively call to get the value's dump. + my $next = &simple_dumper($item->{$key}, $next_indent); + + # If the value is all on one line, remove its indent, so + # will follow the => immediately. If it takes more than + # one line, start it on a new line. + if ($next !~ /\n.*\n/) { + $next =~ s/^ *//; + } + else { + $output .= "\n"; + } + $output .= $next; + } + + $output .= "$indent},\n" if $using_braces; + } + elsif (ref $item eq 'CODE' || ref $item eq 'GLOB') { + $output = $indent . ref($item) . "\n"; + # XXX see if blessed + } + elsif ($item->can('dump')) { + + # By convention in this program, objects furnish a 'dump' + # method. Since not doing any output at this level, just pass + # on the input indent + $output = $item->dump($indent); + } + else { + Carp::my_carp("Can't cope with dumping a " . ref($item) . ". Skipping."); + } + } + return $output; } - close IN; +} - # $Lbrk->Write("Lbrk.pl"); +sub dump_inside_out { + # Dump inside-out hashes in an object's state by converting them to a + # regular hash and then calling simple_dumper on that. + my $object = shift; + my $fields_ref = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; - for (keys %Lbrk) { - $Lbrk{$_}->Write( - ["lib","lb","$_.pl"], - "Linebreak category '$PropValueAlias{lb}{$_}'" - ); + my $addr = main::objaddr $object; + + my %hash; + foreach my $key (keys %$fields_ref) { + $hash{$key} = $fields_ref->{$key}{$addr}; } + + return simple_dumper(\%hash, @_); +} + +sub _operator_dot { + # Overloaded '.' method that is common to all packages. It uses the + # package's stringify method. + + my $self = shift; + my $other = shift; + my $reversed = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + $other = "" unless defined $other; + + foreach my $which (\$self, \$other) { + next unless ref $$which; + if ($$which->can('_operator_stringify')) { + $$which = $$which->_operator_stringify; + } + else { + my $ref = ref $$which; + my $addr = main::objaddr $$which; + $$which = "$ref ($addr)"; + } + } + return ($reversed) + ? "$other$self" + : "$self$other"; +} + +sub _operator_equal { + # Generic overloaded '==' routine. To be equal, they must be the exact + # same object + + my $self = shift; + my $other = shift; + + return 0 unless defined $other; + return 0 unless ref $other; + return main::objaddr $self == main::objaddr $other; +} + +sub _operator_not_equal { + my $self = shift; + my $other = shift; + + return ! _operator_equal($self, $other); } -## -## Process ArabicShaping.txt. -## -sub ArabicShaping_txt() -{ - if (not open IN, "ArabicShaping.txt") { - die "$0: ArabicShaping.txt: $!\n"; +sub process_PropertyAliases($) { + # This reads in the PropertyAliases.txt file, which contains almost all + # the character properties in Unicode and their equivalent aliases: + # scf ; Simple_Case_Folding ; sfc + # + # Field 0 is the preferred short name for the property. + # Field 1 is the full name. + # Any succeeding ones are other accepted names. + + my $file= shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # This whole file was non-existent in early releases, so use our own + # internal one. + $file->insert_lines(get_old_property_aliases()) + if ! -e 'PropertyAliases.txt'; + + # Add any cjk properties that may have been defined. + $file->insert_lines(@cjk_properties); + + while ($file->next_line) { + + my @data = split /\s*;\s*/; + + my $full = $data[1]; + + my $this = Property->new($data[0], Full_Name => $full); + + # Start looking for more aliases after these two. + for my $i (2 .. @data - 1) { + $this->add_alias($data[$i]); + } + } + return; +} + +sub finish_property_setup { + # Finishes setting up after PropertyAliases. - my $ArabLink = Table->New(); - my $ArabLinkGroup = Table->New(); + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; - my %JoinType; + # This entry was missing from this file in earlier Unicode versions + if (-e 'Jamo.txt') { + my $jsn = property_ref('JSN'); + if (! defined $jsn) { + $jsn = Property->new('JSN', Full_Name => 'Jamo_Short_Name'); + } + } - while (<IN>) + # This entry is still missing as of 5.2, perhaps because no short name for + # it. + if (-e 'NameAliases.txt') { + my $aliases = property_ref('Name_Alias'); + if (! defined $aliases) { + $aliases = Property->new('Name_Alias'); + } + } + + # These are used so much, that we set globals for them. + $gc = property_ref('General_Category'); + $block = property_ref('Block'); + + # Perl adds this alias. + $gc->add_alias('Category'); + + # For backwards compatibility, these property files have particular names. + my $upper = property_ref('Uppercase_Mapping'); + $upper->set_core_access('uc()'); + $upper->set_file('Upper'); # This is what utf8.c calls it + + my $lower = property_ref('Lowercase_Mapping'); + $lower->set_core_access('lc()'); + $lower->set_file('Lower'); + + my $title = property_ref('Titlecase_Mapping'); + $title->set_core_access('ucfirst()'); + $title->set_file('Title'); + + my $fold = property_ref('Case_Folding'); + $fold->set_file('Fold') if defined $fold; + + # utf8.c can't currently cope with non range-size-1 for these, and even if + # it were changed to do so, someone else may be using them, expecting the + # old style + foreach my $property (qw { + Case_Folding + Lowercase_Mapping + Titlecase_Mapping + Uppercase_Mapping + }) { - next unless /^[0-9A-Fa-f]+;/; - s/\s+$//; + property_ref($property)->set_range_size_1(1); + } - my ($hexcode, $name, $link, $linkgroup) = split(/\s*;\s*/); - my $code = hex($hexcode); - $ArabLink->Append($code, $link); - $ArabLinkGroup->Append($code, $linkgroup); + # These two properties aren't actually used in the core, but unfortunately + # the names just above that are in the core interfere with these, so + # choose different names. These aren't a problem unless the map tables + # for these files get written out. + my $lowercase = property_ref('Lowercase'); + $lowercase->set_file('IsLower') if defined $lowercase; + my $uppercase = property_ref('Uppercase'); + $uppercase->set_file('IsUpper') if defined $uppercase; + + # Set up the hard-coded default mappings, but only on properties defined + # for this release + foreach my $property (keys %default_mapping) { + my $property_object = property_ref($property); + next if ! defined $property_object; + my $default_map = $default_mapping{$property}; + $property_object->set_default_map($default_map); + + # A map of <code point> implies the property is string. + if ($property_object->type == $UNKNOWN + && $default_map eq $CODE_POINT) + { + $property_object->set_type($STRING); + } + } - $JoinType{$link} ||= Table->New(Is => "JoinType$link"); - $JoinType{$link}->Append($code); + # The following use the Multi_Default class to create objects for + # defaults. + + # Bidi class has a complicated default, but the derived file takes care of + # the complications, leaving just 'L'. + if (file_exists("${EXTRACTED}DBidiClass.txt")) { + property_ref('Bidi_Class')->set_default_map('L'); + } + else { + my $default; + + # The derived file was introduced in 3.1.1. The values below are + # taken from table 3-8, TUS 3.0 + my $default_R = + 'my $default = Range_List->new; + $default->add_range(0x0590, 0x05FF); + $default->add_range(0xFB1D, 0xFB4F);' + ; + + # The defaults apply only to unassigned characters + $default_R .= '$gc->table("Cn") & $default;'; + + if ($v_version lt v3.0.0) { + $default = Multi_Default->new(R => $default_R, 'L'); + } + else { + + # AL apparently not introduced until 3.0: TUS 2.x references are + # not on-line to check it out + my $default_AL = + 'my $default = Range_List->new; + $default->add_range(0x0600, 0x07BF); + $default->add_range(0xFB50, 0xFDFF); + $default->add_range(0xFE70, 0xFEFF);' + ; + + # Non-character code points introduced in this release; aren't AL + if ($v_version ge 3.1.0) { + $default_AL .= '$default->delete_range(0xFDD0, 0xFDEF);'; + } + $default_AL .= '$gc->table("Cn") & $default'; + $default = Multi_Default->new(AL => $default_AL, + R => $default_R, + 'L'); + } + property_ref('Bidi_Class')->set_default_map($default); } - close IN; - # $ArabLink->Write("ArabLink.pl"); - # $ArabLinkGroup->Write("ArabLnkGrp.pl"); + # Joining type has a complicated default, but the derived file takes care + # of the complications, leaving just 'U' (or Non_Joining), except the file + # is bad in 3.1.0 + if (file_exists("${EXTRACTED}DJoinType.txt") || -e 'ArabicShaping.txt') { + if (file_exists("${EXTRACTED}DJoinType.txt") && $v_version ne 3.1.0) { + property_ref('Joining_Type')->set_default_map('Non_Joining'); + } + else { + + # Otherwise, there are not one, but two possibilities for the + # missing defaults: T and U. + # The missing defaults that evaluate to T are given by: + # T = Mn + Cf - ZWNJ - ZWJ + # where Mn and Cf are the general category values. In other words, + # any non-spacing mark or any format control character, except + # U+200C ZERO WIDTH NON-JOINER (joining type U) and U+200D ZERO + # WIDTH JOINER (joining type C). + my $default = Multi_Default->new( + 'T' => '$gc->table("Mn") + $gc->table("Cf") - 0x200C - 0x200D', + 'Non_Joining'); + property_ref('Joining_Type')->set_default_map($default); + } + } + # Line break has a complicated default in early releases. It is 'Unknown' + # for non-assigned code points; 'AL' for assigned. + if (file_exists("${EXTRACTED}DLineBreak.txt") || -e 'LineBreak.txt') { + my $lb = property_ref('Line_Break'); + if ($v_version gt 3.2.0) { + $lb->set_default_map('Unknown'); + } + else { + my $default = Multi_Default->new( 'Unknown' => '$gc->table("Cn")', + 'AL'); + $lb->set_default_map($default); + } - for (keys %JoinType) { - $JoinType{$_}->Write( - ["lib","jt","$_.pl"], - "JoiningType category '$PropValueAlias{jt}{$_}'" - ); + # If has the URS property, make sure that the standard aliases are in + # it, since not in the input tables in some versions. + my $urs = property_ref('Unicode_Radical_Stroke'); + if (defined $urs) { + $urs->add_alias('cjkRSUnicode'); + $urs->add_alias('kRSUnicode'); + } } + return; } -## -## Process EastAsianWidth.txt. -## -sub EastAsianWidth_txt() -{ - if (not open IN, "EastAsianWidth.txt") { - die "$0: EastAsianWidth.txt: $!\n"; +sub get_old_property_aliases() { + # Returns what would be in PropertyAliases.txt if it existed in very old + # versions of Unicode. It was derived from the one in 3.2, and pared + # down based on the data that was actually in the older releases. + # An attempt was made to use the existence of files to mean inclusion or + # not of various aliases, but if this was not sufficient, using version + # numbers was resorted to. + + my @return; + + # These are to be used in all versions (though some are constructed by + # this program if missing) + push @return, split /\n/, <<'END'; +bc ; Bidi_Class +Bidi_M ; Bidi_Mirrored +cf ; Case_Folding +ccc ; Canonical_Combining_Class +dm ; Decomposition_Mapping +dt ; Decomposition_Type +gc ; General_Category +isc ; ISO_Comment +lc ; Lowercase_Mapping +na ; Name +na1 ; Unicode_1_Name +nt ; Numeric_Type +nv ; Numeric_Value +sfc ; Simple_Case_Folding +slc ; Simple_Lowercase_Mapping +stc ; Simple_Titlecase_Mapping +suc ; Simple_Uppercase_Mapping +tc ; Titlecase_Mapping +uc ; Uppercase_Mapping +END + + if (-e 'Blocks.txt') { + push @return, "blk ; Block\n"; + } + if (-e 'ArabicShaping.txt') { + push @return, split /\n/, <<'END'; +jg ; Joining_Group +jt ; Joining_Type +END + } + if (-e 'PropList.txt') { + + # This first set is in the original old-style proplist. + push @return, split /\n/, <<'END'; +Alpha ; Alphabetic +Bidi_C ; Bidi_Control +Dash ; Dash +Dia ; Diacritic +Ext ; Extender +Hex ; Hex_Digit +Hyphen ; Hyphen +IDC ; ID_Continue +Ideo ; Ideographic +Join_C ; Join_Control +Math ; Math +QMark ; Quotation_Mark +Term ; Terminal_Punctuation +WSpace ; White_Space +END + # The next sets were added later + if ($v_version ge v3.0.0) { + push @return, split /\n/, <<'END'; +Upper ; Uppercase +Lower ; Lowercase +END + } + if ($v_version ge v3.0.1) { + push @return, split /\n/, <<'END'; +NChar ; Noncharacter_Code_Point +END + } + # The next sets were added in the new-style + if ($v_version ge v3.1.0) { + push @return, split /\n/, <<'END'; +OAlpha ; Other_Alphabetic +OLower ; Other_Lowercase +OMath ; Other_Math +OUpper ; Other_Uppercase +END + } + if ($v_version ge v3.1.1) { + push @return, "AHex ; ASCII_Hex_Digit\n"; + } + } + if (-e 'EastAsianWidth.txt') { + push @return, "ea ; East_Asian_Width\n"; + } + if (-e 'CompositionExclusions.txt') { + push @return, "CE ; Composition_Exclusion\n"; + } + if (-e 'LineBreak.txt') { + push @return, "lb ; Line_Break\n"; + } + if (-e 'BidiMirroring.txt') { + push @return, "bmg ; Bidi_Mirroring_Glyph\n"; + } + if (-e 'Scripts.txt') { + push @return, "sc ; Script\n"; + } + if (-e 'DNormalizationProps.txt') { + push @return, split /\n/, <<'END'; +Comp_Ex ; Full_Composition_Exclusion +FC_NFKC ; FC_NFKC_Closure +NFC_QC ; NFC_Quick_Check +NFD_QC ; NFD_Quick_Check +NFKC_QC ; NFKC_Quick_Check +NFKD_QC ; NFKD_Quick_Check +XO_NFC ; Expands_On_NFC +XO_NFD ; Expands_On_NFD +XO_NFKC ; Expands_On_NFKC +XO_NFKD ; Expands_On_NFKD +END + } + if (-e 'DCoreProperties.txt') { + push @return, split /\n/, <<'END'; +IDS ; ID_Start +XIDC ; XID_Continue +XIDS ; XID_Start +END + # These can also appear in some versions of PropList.txt + push @return, "Lower ; Lowercase\n" + unless grep { $_ =~ /^Lower\b/} @return; + push @return, "Upper ; Uppercase\n" + unless grep { $_ =~ /^Upper\b/} @return; } - my %EAW; + # This flag requires the DAge.txt file to be copied into the directory. + if (DEBUG && $compare_versions) { + push @return, 'age ; Age'; + } - while (<IN>) - { - next unless /^[0-9A-Fa-f]+(\.\.[0-9A-Fa-f]+)?;/; - s/#.*//; - s/\s+$//; + return @return; +} - my ($hexcodes, $pv) = split(/\s*;\s*/); - $EAW{$pv} ||= Table->New(Is => "EastAsianWidth$pv"); - my ($start, $end) = split(/\.\./, $hexcodes); - if (defined $end) { - $EAW{$pv}->AppendRange(hex($start), hex($end)); - } else { - $EAW{$pv}->Append(hex($start)); - } +sub process_PropValueAliases { + # This file contains values that properties look like: + # bc ; AL ; Arabic_Letter + # blk; n/a ; Greek_And_Coptic ; Greek + # + # Field 0 is the property. + # Field 1 is the short name of a property value or 'n/a' if no + # short name exists; + # Field 2 is the full property value name; + # Any other fields are more synonyms for the property value. + # Purely numeric property values are omitted from the file; as are some + # others, fewer and fewer in later releases + + # Entries for the ccc property have an extra field before the + # abbreviation: + # ccc; 0; NR ; Not_Reordered + # It is the numeric value that the names are synonyms for. + + # There are comment entries for values missing from this file: + # # @missing: 0000..10FFFF; ISO_Comment; <none> + # # @missing: 0000..10FFFF; Lowercase_Mapping; <code point> + + my $file= shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # This whole file was non-existent in early releases, so use our own + # internal one if necessary. + if (! -e 'PropValueAliases.txt') { + $file->insert_lines(get_old_property_value_aliases()); } - close IN; + # Add any explicit cjk values + $file->insert_lines(@cjk_property_values); + + # This line is used only for testing the code that checks for name + # conflicts. There is a script Inherited, and when this line is executed + # it causes there to be a name conflict with the 'Inherited' that this + # program generates for this block property value + #$file->insert_lines('blk; n/a; Herited'); - for (keys %EAW) { - $EAW{$_}->Write( - ["lib","ea","$_.pl"], - "EastAsianWidth category '$PropValueAlias{ea}{$_}'" - ); + + # Process each line of the file ... + while ($file->next_line) { + + my ($property, @data) = split /\s*;\s*/; + + # The full name for the ccc property value is in field 2 of the + # remaining ones; field 1 for all other properties. Swap ccc fields 1 + # and 2. (Rightmost splice removes field 2, returning it; left splice + # inserts that into field 1, thus shifting former field 1 to field 2.) + splice (@data, 1, 0, splice(@data, 2, 1)) if $property eq 'ccc'; + + # If there is no short name, use the full one in element 1 + $data[0] = $data[1] if $data[0] eq "n/a"; + + # Earlier releases had the pseudo property 'qc' that should expand to + # the ones that replace it below. + if ($property eq 'qc') { + if (lc $data[0] eq 'y') { + $file->insert_lines('NFC_QC; Y ; Yes', + 'NFD_QC; Y ; Yes', + 'NFKC_QC; Y ; Yes', + 'NFKD_QC; Y ; Yes', + ); + } + elsif (lc $data[0] eq 'n') { + $file->insert_lines('NFC_QC; N ; No', + 'NFD_QC; N ; No', + 'NFKC_QC; N ; No', + 'NFKD_QC; N ; No', + ); + } + elsif (lc $data[0] eq 'm') { + $file->insert_lines('NFC_QC; M ; Maybe', + 'NFKC_QC; M ; Maybe', + ); + } + else { + $file->carp_bad_line("qc followed by unexpected '$data[0]"); + } + next; + } + + # The first field is the short name, 2nd is the full one. + my $property_object = property_ref($property); + my $table = $property_object->add_match_table($data[0], + Full_Name => $data[1]); + + # Start looking for more aliases after these two. + for my $i (2 .. @data - 1) { + $table->add_alias($data[$i]); + } + } # End of looping through the file + + # As noted in the comments early in the program, it generates tables for + # the default values for all releases, even those for which the concept + # didn't exist at the time. Here we add those if missing. + my $age = property_ref('age'); + if (defined $age && ! defined $age->table('Unassigned')) { + $age->add_match_table('Unassigned'); + } + $block->add_match_table('No_Block') if -e 'Blocks.txt' + && ! defined $block->table('No_Block'); + + + # Now set the default mappings of the properties from the file. This is + # done after the loop because a number of properties have only @missings + # entries in the file, and may not show up until the end. + my @defaults = $file->get_missings; + foreach my $default_ref (@defaults) { + my $default = $default_ref->[0]; + my $property = property_ref($default_ref->[1]); + $property->set_default_map($default); } + return; } -## -## Process HangulSyllableType.txt. -## -sub HangulSyllableType_txt() -{ - if (not open IN, "HangulSyllableType.txt") { - die "$0: HangulSyllableType.txt: $!\n"; +sub get_old_property_value_aliases () { + # Returns what would be in PropValueAliases.txt if it existed in very old + # versions of Unicode. It was derived from the one in 3.2, and pared + # down. An attempt was made to use the existence of files to mean + # inclusion or not of various aliases, but if this was not sufficient, + # using version numbers was resorted to. + + my @return = split /\n/, <<'END'; +bc ; AN ; Arabic_Number +bc ; B ; Paragraph_Separator +bc ; CS ; Common_Separator +bc ; EN ; European_Number +bc ; ES ; European_Separator +bc ; ET ; European_Terminator +bc ; L ; Left_To_Right +bc ; ON ; Other_Neutral +bc ; R ; Right_To_Left +bc ; WS ; White_Space + +# The standard combining classes are very much different in v1, so only use +# ones that look right (not checked thoroughly) +ccc; 0; NR ; Not_Reordered +ccc; 1; OV ; Overlay +ccc; 7; NK ; Nukta +ccc; 8; KV ; Kana_Voicing +ccc; 9; VR ; Virama +ccc; 202; ATBL ; Attached_Below_Left +ccc; 216; ATAR ; Attached_Above_Right +ccc; 218; BL ; Below_Left +ccc; 220; B ; Below +ccc; 222; BR ; Below_Right +ccc; 224; L ; Left +ccc; 228; AL ; Above_Left +ccc; 230; A ; Above +ccc; 232; AR ; Above_Right +ccc; 234; DA ; Double_Above + +dt ; can ; canonical +dt ; enc ; circle +dt ; fin ; final +dt ; font ; font +dt ; fra ; fraction +dt ; init ; initial +dt ; iso ; isolated +dt ; med ; medial +dt ; n/a ; none +dt ; nb ; noBreak +dt ; sqr ; square +dt ; sub ; sub +dt ; sup ; super + +gc ; C ; Other # Cc | Cf | Cn | Co | Cs +gc ; Cc ; Control +gc ; Cn ; Unassigned +gc ; Co ; Private_Use +gc ; L ; Letter # Ll | Lm | Lo | Lt | Lu +gc ; LC ; Cased_Letter # Ll | Lt | Lu +gc ; Ll ; Lowercase_Letter +gc ; Lm ; Modifier_Letter +gc ; Lo ; Other_Letter +gc ; Lu ; Uppercase_Letter +gc ; M ; Mark # Mc | Me | Mn +gc ; Mc ; Spacing_Mark +gc ; Mn ; Nonspacing_Mark +gc ; N ; Number # Nd | Nl | No +gc ; Nd ; Decimal_Number +gc ; No ; Other_Number +gc ; P ; Punctuation # Pc | Pd | Pe | Pf | Pi | Po | Ps +gc ; Pd ; Dash_Punctuation +gc ; Pe ; Close_Punctuation +gc ; Po ; Other_Punctuation +gc ; Ps ; Open_Punctuation +gc ; S ; Symbol # Sc | Sk | Sm | So +gc ; Sc ; Currency_Symbol +gc ; Sm ; Math_Symbol +gc ; So ; Other_Symbol +gc ; Z ; Separator # Zl | Zp | Zs +gc ; Zl ; Line_Separator +gc ; Zp ; Paragraph_Separator +gc ; Zs ; Space_Separator + +nt ; de ; Decimal +nt ; di ; Digit +nt ; n/a ; None +nt ; nu ; Numeric +END + + if (-e 'ArabicShaping.txt') { + push @return, split /\n/, <<'END'; +jg ; n/a ; AIN +jg ; n/a ; ALEF +jg ; n/a ; DAL +jg ; n/a ; GAF +jg ; n/a ; LAM +jg ; n/a ; MEEM +jg ; n/a ; NO_JOINING_GROUP +jg ; n/a ; NOON +jg ; n/a ; QAF +jg ; n/a ; SAD +jg ; n/a ; SEEN +jg ; n/a ; TAH +jg ; n/a ; WAW + +jt ; C ; Join_Causing +jt ; D ; Dual_Joining +jt ; L ; Left_Joining +jt ; R ; Right_Joining +jt ; U ; Non_Joining +jt ; T ; Transparent +END + if ($v_version ge v3.0.0) { + push @return, split /\n/, <<'END'; +jg ; n/a ; ALAPH +jg ; n/a ; BEH +jg ; n/a ; BETH +jg ; n/a ; DALATH_RISH +jg ; n/a ; E +jg ; n/a ; FEH +jg ; n/a ; FINAL_SEMKATH +jg ; n/a ; GAMAL +jg ; n/a ; HAH +jg ; n/a ; HAMZA_ON_HEH_GOAL +jg ; n/a ; HE +jg ; n/a ; HEH +jg ; n/a ; HEH_GOAL +jg ; n/a ; HETH +jg ; n/a ; KAF +jg ; n/a ; KAPH +jg ; n/a ; KNOTTED_HEH +jg ; n/a ; LAMADH +jg ; n/a ; MIM +jg ; n/a ; NUN +jg ; n/a ; PE +jg ; n/a ; QAPH +jg ; n/a ; REH +jg ; n/a ; REVERSED_PE +jg ; n/a ; SADHE +jg ; n/a ; SEMKATH +jg ; n/a ; SHIN +jg ; n/a ; SWASH_KAF +jg ; n/a ; TAW +jg ; n/a ; TEH_MARBUTA +jg ; n/a ; TETH +jg ; n/a ; YEH +jg ; n/a ; YEH_BARREE +jg ; n/a ; YEH_WITH_TAIL +jg ; n/a ; YUDH +jg ; n/a ; YUDH_HE +jg ; n/a ; ZAIN +END + } } - my %HST; - while (<IN>) - { - next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(\w+)/; - my ($first, $last, $pv) = (hex($1), hex($2||""), $3); + if (-e 'EastAsianWidth.txt') { + push @return, split /\n/, <<'END'; +ea ; A ; Ambiguous +ea ; F ; Fullwidth +ea ; H ; Halfwidth +ea ; N ; Neutral +ea ; Na ; Narrow +ea ; W ; Wide +END + } - $HST{$pv} ||= Table->New(Is => "HangulSyllableType$pv"); - $HST{$pv}->Append($first); + if (-e 'LineBreak.txt') { + push @return, split /\n/, <<'END'; +lb ; AI ; Ambiguous +lb ; AL ; Alphabetic +lb ; B2 ; Break_Both +lb ; BA ; Break_After +lb ; BB ; Break_Before +lb ; BK ; Mandatory_Break +lb ; CB ; Contingent_Break +lb ; CL ; Close_Punctuation +lb ; CM ; Combining_Mark +lb ; CR ; Carriage_Return +lb ; EX ; Exclamation +lb ; GL ; Glue +lb ; HY ; Hyphen +lb ; ID ; Ideographic +lb ; IN ; Inseperable +lb ; IS ; Infix_Numeric +lb ; LF ; Line_Feed +lb ; NS ; Nonstarter +lb ; NU ; Numeric +lb ; OP ; Open_Punctuation +lb ; PO ; Postfix_Numeric +lb ; PR ; Prefix_Numeric +lb ; QU ; Quotation +lb ; SA ; Complex_Context +lb ; SG ; Surrogate +lb ; SP ; Space +lb ; SY ; Break_Symbols +lb ; XX ; Unknown +lb ; ZW ; ZWSpace +END + } - if ($last) { $HST{$pv}->Extend($last) } + if (-e 'DNormalizationProps.txt') { + push @return, split /\n/, <<'END'; +qc ; M ; Maybe +qc ; N ; No +qc ; Y ; Yes +END } - close IN; - for (keys %HST) { - $HST{$_}->Write( - ["lib","hst","$_.pl"], - "HangulSyllableType category '$PropValueAlias{hst}{$_}'" - ); + if (-e 'Scripts.txt') { + push @return, split /\n/, <<'END'; +sc ; Arab ; Arabic +sc ; Armn ; Armenian +sc ; Beng ; Bengali +sc ; Bopo ; Bopomofo +sc ; Cans ; Canadian_Aboriginal +sc ; Cher ; Cherokee +sc ; Cyrl ; Cyrillic +sc ; Deva ; Devanagari +sc ; Dsrt ; Deseret +sc ; Ethi ; Ethiopic +sc ; Geor ; Georgian +sc ; Goth ; Gothic +sc ; Grek ; Greek +sc ; Gujr ; Gujarati +sc ; Guru ; Gurmukhi +sc ; Hang ; Hangul +sc ; Hani ; Han +sc ; Hebr ; Hebrew +sc ; Hira ; Hiragana +sc ; Ital ; Old_Italic +sc ; Kana ; Katakana +sc ; Khmr ; Khmer +sc ; Knda ; Kannada +sc ; Laoo ; Lao +sc ; Latn ; Latin +sc ; Mlym ; Malayalam +sc ; Mong ; Mongolian +sc ; Mymr ; Myanmar +sc ; Ogam ; Ogham +sc ; Orya ; Oriya +sc ; Qaai ; Inherited +sc ; Runr ; Runic +sc ; Sinh ; Sinhala +sc ; Syrc ; Syriac +sc ; Taml ; Tamil +sc ; Telu ; Telugu +sc ; Thaa ; Thaana +sc ; Thai ; Thai +sc ; Tibt ; Tibetan +sc ; Yiii ; Yi +sc ; Zyyy ; Common +END } -} -## -## Process Jamo.txt. -## -sub Jamo_txt() -{ - if (not open IN, "Jamo.txt") { - die "$0: Jamo.txt: $!\n"; + if ($v_version ge v2.0.0) { + push @return, split /\n/, <<'END'; +dt ; com ; compat +dt ; nar ; narrow +dt ; sml ; small +dt ; vert ; vertical +dt ; wide ; wide + +gc ; Cf ; Format +gc ; Cs ; Surrogate +gc ; Lt ; Titlecase_Letter +gc ; Me ; Enclosing_Mark +gc ; Nl ; Letter_Number +gc ; Pc ; Connector_Punctuation +gc ; Sk ; Modifier_Symbol +END + } + if ($v_version ge v2.1.2) { + push @return, "bc ; S ; Segment_Separator\n"; + } + if ($v_version ge v2.1.5) { + push @return, split /\n/, <<'END'; +gc ; Pf ; Final_Punctuation +gc ; Pi ; Initial_Punctuation +END + } + if ($v_version ge v2.1.8) { + push @return, "ccc; 240; IS ; Iota_Subscript\n"; } - my $Short = Table->New(); - while (<IN>) - { - next unless /^([0-9A-Fa-f]+)\s*;\s*(\w*)/; - my ($code, $short) = (hex($1), $2); + if ($v_version ge v3.0.0) { + push @return, split /\n/, <<'END'; +bc ; AL ; Arabic_Letter +bc ; BN ; Boundary_Neutral +bc ; LRE ; Left_To_Right_Embedding +bc ; LRO ; Left_To_Right_Override +bc ; NSM ; Nonspacing_Mark +bc ; PDF ; Pop_Directional_Format +bc ; RLE ; Right_To_Left_Embedding +bc ; RLO ; Right_To_Left_Override + +ccc; 233; DB ; Double_Below +END + } - $Short->Append($code, $short); + if ($v_version ge v3.1.0) { + push @return, "ccc; 226; R ; Right\n"; } - close IN; - # $Short->Write("JamoShort.pl"); + + return @return; } -## -## Process Scripts.txt. -## -sub Scripts_txt() -{ - my @ScriptInfo; +{ # Closure + # This is used to store the range list of all the code points usable when + # the little used $compare_versions feature is enabled. + my $compare_versions_range_list; + + sub process_generic_property_file { + # This processes a file containing property mappings and puts them + # into internal map tables. It should be used to handle any property + # files that have mappings from a code point or range thereof to + # something else. This means almost all the UCD .txt files. + # each_line_handlers() should be set to adjust the lines of these + # files, if necessary, to what this routine understands: + # + # 0374 ; NFD_QC; N + # 003C..003E ; Math + # + # the fields are: "codepoint range ; property; map" + # + # meaning the codepoints in the range all have the value 'map' under + # 'property'. + # Beginning and trailing white space in each field are not signficant. + # Note there is not a trailing semi-colon in the above. A trailing + # semi-colon means the map is a null-string. An omitted map, as + # opposed to a null-string, is assumed to be 'Y', based on Unicode + # table syntax. (This could have been hidden from this routine by + # doing it in the $file object, but that would require parsing of the + # line there, so would have to parse it twice, or change the interface + # to pass this an array. So not done.) + # + # The map field may begin with a sequence of commands that apply to + # this range. Each such command begins and ends with $CMD_DELIM. + # These are used to indicate, for example, that the mapping for a + # range has a non-default type. + # + # This loops through the file, calling it's next_line() method, and + # then taking the map and adding it to the property's table. + # Complications arise because any number of properties can be in the + # file, in any order, interspersed in any way. The first time a + # property is seen, it gets information about that property and + # caches it for quick retrieval later. It also normalizes the maps + # so that only one of many synonym is stored. The Unicode input files + # do use some multiple synonyms. + + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my %property_info; # To keep track of what properties + # have already had entries in the + # current file, and info about each, + # so don't have to recompute. + my $property_name; # property currently being worked on + my $property_type; # and its type + my $previous_property_name = ""; # name from last time through loop + my $property_object; # pointer to the current property's + # object + my $property_addr; # the address of that object + my $default_map; # the string that code points missing + # from the file map to + my $default_table; # For non-string properties, a + # reference to the match table that + # will contain the list of code + # points that map to $default_map. + + # Get the next real non-comment line + LINE: + while ($file->next_line) { + + # Default replacement type; means that if parts of the range have + # already been stored in our tables, the new map overrides them if + # they differ more than cosmetically + my $replace = $IF_NOT_EQUIVALENT; + my $map_type; # Default type for the map of this range + + #local $to_trace = 1 if main::DEBUG; + trace $_ if main::DEBUG && $to_trace; + + # Split the line into components + my ($range, $property_name, $map, @remainder) + = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields + + # If more or less on the line than we are expecting, warn and skip + # the line + if (@remainder) { + $file->carp_bad_line('Extra fields'); + next LINE; + } + elsif ( ! defined $property_name) { + $file->carp_bad_line('Missing property'); + next LINE; + } + + # Examine the range. + if ($range !~ /^ ($code_point_re) (?:\.\. ($code_point_re) )? $/x) + { + $file->carp_bad_line("Range '$range' not of the form 'CP1' or 'CP1..CP2' (where CP1,2 are code points in hex)"); + next LINE; + } + my $low = hex $1; + my $high = (defined $2) ? hex $2 : $low; + + # For the very specialized case of comparing two Unicode + # versions... + if (DEBUG && $compare_versions) { + if ($property_name eq 'Age') { + + # Only allow code points at least as old as the version + # specified. + my $age = pack "C*", split(/\./, $map); # v string + next LINE if $age gt $compare_versions; + } + else { + + # Again, we throw out code points younger than those of + # the specified version. By now, the Age property is + # populated. We use the intersection of each input range + # with this property to find what code points in it are + # valid. To do the intersection, we have to convert the + # Age property map to a Range_list. We only have to do + # this once. + if (! defined $compare_versions_range_list) { + my $age = property_ref('Age'); + if (! -e 'DAge.txt') { + croak "Need to have 'DAge.txt' file to do version comparison"; + } + elsif ($age->count == 0) { + croak "The 'Age' table is empty, but its file exists"; + } + $compare_versions_range_list + = Range_List->new(Initialize => $age); + } - if (not open(IN, "Scripts.txt")) { - die "$0: Scripts.txt: $!\n"; + # An undefined map is always 'Y' + $map = 'Y' if ! defined $map; + + # Calculate the intersection of the input range with the + # code points that are known in the specified version + my @ranges = ($compare_versions_range_list + & Range->new($low, $high))->ranges; + + # If the intersection is empty, throw away this range + next LINE unless @ranges; + + # Only examine the first range this time through the loop. + my $this_range = shift @ranges; + + # Put any remaining ranges in the queue to be processed + # later. Note that there is unnecessary work here, as we + # will do the intersection again for each of these ranges + # during some future iteration of the LINE loop, but this + # code is not used in production. The later intersections + # are guaranteed to not splinter, so this will not become + # an infinite loop. + my $line = join ';', $property_name, $map; + foreach my $range (@ranges) { + $file->insert_adjusted_lines(sprintf("%04X..%04X; %s", + $range->start, + $range->end, + $line)); + } + + # And process the first range, like any other. + $low = $this_range->start; + $high = $this_range->end; + } + } # End of $compare_versions + + # If changing to a new property, get the things constant per + # property + if ($previous_property_name ne $property_name) { + + $property_object = property_ref($property_name); + if (! defined $property_object) { + $file->carp_bad_line("Unexpected property '$property_name'. Skipped"); + next LINE; + } + $property_addr = main::objaddr($property_object); + + # Defer changing names until have a line that is acceptable + # (the 'next' statement above means is unacceptable) + $previous_property_name = $property_name; + + # If not the first time for this property, retrieve info about + # it from the cache + if (defined ($property_info{$property_addr}{'type'})) { + $property_type = $property_info{$property_addr}{'type'}; + $default_map = $property_info{$property_addr}{'default'}; + $map_type + = $property_info{$property_addr}{'pseudo_map_type'}; + $default_table + = $property_info{$property_addr}{'default_table'}; + } + else { + + # Here, is the first time for this property. Set up the + # cache. + $property_type = $property_info{$property_addr}{'type'} + = $property_object->type; + $map_type + = $property_info{$property_addr}{'pseudo_map_type'} + = $property_object->pseudo_map_type; + + # The Unicode files are set up so that if the map is not + # defined, it is a binary property + if (! defined $map && $property_type != $BINARY) { + if ($property_type != $UNKNOWN + && $property_type != $NON_STRING) + { + $file->carp_bad_line("No mapping defined on a non-binary property. Using 'Y' for the map"); + } + else { + $property_object->set_type($BINARY); + $property_type + = $property_info{$property_addr}{'type'} + = $BINARY; + } + } + + # Get any @missings default for this property. This + # should precede the first entry for the property in the + # input file, and is located in a comment that has been + # stored by the Input_file class until we access it here. + # It's possible that there is more than one such line + # waiting for us; collect them all, and parse + my @missings_list = $file->get_missings + if $file->has_missings_defaults; + foreach my $default_ref (@missings_list) { + my $default = $default_ref->[0]; + my $addr = objaddr property_ref($default_ref->[1]); + + # For string properties, the default is just what the + # file says, but non-string properties should already + # have set up a table for the default property value; + # use the table for these, so can resolve synonyms + # later to a single standard one. + if ($property_type == $STRING + || $property_type == $UNKNOWN) + { + $property_info{$addr}{'missings'} = $default; + } + else { + $property_info{$addr}{'missings'} + = $property_object->table($default); + } + } + + # Finished storing all the @missings defaults in the input + # file so far. Get the one for the current property. + my $missings = $property_info{$property_addr}{'missings'}; + + # But we likely have separately stored what the default + # should be. (This is to accommodate versions of the + # standard where the @missings lines are absent or + # incomplete.) Hopefully the two will match. But check + # it out. + $default_map = $property_object->default_map; + + # If the map is a ref, it means that the default won't be + # processed until later, so undef it, so next few lines + # will redefine it to something that nothing will match + undef $default_map if ref $default_map; + + # Create a $default_map if don't have one; maybe a dummy + # that won't match anything. + if (! defined $default_map) { + + # Use any @missings line in the file. + if (defined $missings) { + if (ref $missings) { + $default_map = $missings->full_name; + $default_table = $missings; + } + else { + $default_map = $missings; + } + # And store it with the property for outside use. + $property_object->set_default_map($default_map); + } + else { + + # Neither an @missings nor a default map. Create + # a dummy one, so won't have to test definedness + # in the main loop. + $default_map = '_Perl This will never be in a file + from Unicode'; + } + } + + # Here, we have $default_map defined, possibly in terms of + # $missings, but maybe not, and possibly is a dummy one. + if (defined $missings) { + + # Make sure there is no conflict between the two. + # $missings has priority. + if (ref $missings) { + $default_table + = $property_object->table($default_map); + if (! defined $default_table + || $default_table != $missings) + { + if (! defined $default_table) { + $default_table = $UNDEF; + } + $file->carp_bad_line(<<END +The \@missings line for $property_name in $file says that missings default to +$missings, but we expect it to be $default_table. $missings used. +END + ); + $default_table = $missings; + $default_map = $missings->full_name; + } + $property_info{$property_addr}{'default_table'} + = $default_table; + } + elsif ($default_map ne $missings) { + $file->carp_bad_line(<<END +The \@missings line for $property_name in $file says that missings default to +$missings, but we expect it to be $default_map. $missings used. +END + ); + $default_map = $missings; + } + } + + $property_info{$property_addr}{'default'} + = $default_map; + + # If haven't done so already, find the table corresponding + # to this map for non-string properties. + if (! defined $default_table + && $property_type != $STRING + && $property_type != $UNKNOWN) + { + $default_table = $property_info{$property_addr} + {'default_table'} + = $property_object->table($default_map); + } + } # End of is first time for this property + } # End of switching properties. + + # Ready to process the line. + # The Unicode files are set up so that if the map is not defined, + # it is a binary property with value 'Y' + if (! defined $map) { + $map = 'Y'; + } + else { + + # If the map begins with a special command to us (enclosed in + # delimiters), extract the command(s). + if (substr($map, 0, 1) eq $CMD_DELIM) { + while ($map =~ s/ ^ $CMD_DELIM (.*?) $CMD_DELIM //x) { + my $command = $1; + if ($command =~ / ^ $REPLACE_CMD= (.*) /x) { + $replace = $1; + } + elsif ($command =~ / ^ $MAP_TYPE_CMD= (.*) /x) { + $map_type = $1; + } + else { + $file->carp_bad_line("Unknown command line: '$1'"); + next LINE; + } + } + } + } + + if ($default_map eq $CODE_POINT && $map =~ / ^ $code_point_re $/x) + { + + # Here, we have a map to a particular code point, and the + # default map is to a code point itself. If the range + # includes the particular code point, change that portion of + # the range to the default. This makes sure that in the final + # table only the non-defaults are listed. + my $decimal_map = hex $map; + if ($low <= $decimal_map && $decimal_map <= $high) { + + # If the range includes stuff before or after the map + # we're changing, split it and process the split-off parts + # later. + if ($low < $decimal_map) { + $file->insert_adjusted_lines( + sprintf("%04X..%04X; %s; %s", + $low, + $decimal_map - 1, + $property_name, + $map)); + } + if ($high > $decimal_map) { + $file->insert_adjusted_lines( + sprintf("%04X..%04X; %s; %s", + $decimal_map + 1, + $high, + $property_name, + $map)); + } + $low = $high = $decimal_map; + $map = $CODE_POINT; + } + } + + # If we can tell that this is a synonym for the default map, use + # the default one instead. + if ($property_type != $STRING + && $property_type != $UNKNOWN) + { + my $table = $property_object->table($map); + if (defined $table && $table == $default_table) { + $map = $default_map; + } + } + + # And figure out the map type if not known. + if (! defined $map_type || $map_type == $COMPUTE_NO_MULTI_CP) { + if ($map eq "") { # Nulls are always $NULL map type + $map_type = $NULL; + } # Otherwise, non-strings, and those that don't allow + # $MULTI_CP, and those that aren't multiple code points are + # 0 + elsif + (($property_type != $STRING && $property_type != $UNKNOWN) + || (defined $map_type && $map_type == $COMPUTE_NO_MULTI_CP) + || $map !~ /^ $code_point_re ( \ $code_point_re )+ $ /x) + { + $map_type = 0; + } + else { + $map_type = $MULTI_CP; + } + } + + $property_object->add_map($low, $high, + $map, + Type => $map_type, + Replace => $replace); + } # End of loop through file's lines + + return; } - while (<IN>) { - next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/; +} - # Wait until all the scripts have been read since - # they are not listed in numeric order. - push @ScriptInfo, [ hex($1), hex($2||""), $3 ]; +# XXX Unused until revise charnames; +#sub check_and_handle_compound_name { +# This looks at Name properties for parenthesized components and splits +# them off. Thus it finds FF as an equivalent to Form Feed. +# my $code_point = shift; +# my $name = shift; +# if ($name =~ /^ ( .*? ) ( \s* ) \( ( [^)]* ) \) (.*) $/x) { +# #local $to_trace = 1 if main::DEBUG; +# trace $1, $2, $3, $4 if main::DEBUG && $to_trace; +# push @more_Names, "$code_point; $1"; +# push @more_Names, "$code_point; $3"; +# Carp::my_carp_bug("Expecting blank space before left parenthesis in '$_'. Proceeding and assuming it was there;") if $2 ne " "; +# Carp::my_carp_bug("Not expecting anything after the right parenthesis in '$_'. Proceeding and ignoring that;") if $4 ne ""; +# } +# return; +#} + +{ # Closure for UnicodeData.txt handling + + # This file was the first one in the UCD; its design leads to some + # awkwardness in processing. Here is a sample line: + # 0041;LATIN CAPITAL LETTER A;Lu;0;L;;;;;N;;;;0061; + # The fields in order are: + my $i = 0; # The code point is in field 0, and is shifted off. + my $NAME = $i++; # character name (e.g. "LATIN CAPITAL LETTER A") + my $CATEGORY = $i++; # category (e.g. "Lu") + my $CCC = $i++; # Canonical combining class (e.g. "230") + my $BIDI = $i++; # directional class (e.g. "L") + my $PERL_DECOMPOSITION = $i++; # decomposition mapping + my $PERL_DECIMAL_DIGIT = $i++; # decimal digit value + my $NUMERIC_TYPE_OTHER_DIGIT = $i++; # digit value, like a superscript + # Dual-use in this program; see below + my $NUMERIC = $i++; # numeric value + my $MIRRORED = $i++; # ? mirrored + my $UNICODE_1_NAME = $i++; # name in Unicode 1.0 + my $COMMENT = $i++; # iso comment + my $UPPER = $i++; # simple uppercase mapping + my $LOWER = $i++; # simple lowercase mapping + my $TITLE = $i++; # simple titlecase mapping + my $input_field_count = $i; + + # This routine in addition outputs these extra fields: + my $DECOMP_TYPE = $i++; # Decomposition type + my $DECOMP_MAP = $i++; # Must be last; another decomposition mapping + my $last_field = $i - 1; + + # All these are read into an array for each line, with the indices defined + # above. The empty fields in the example line above indicate that the + # value is defaulted. The handler called for each line of the input + # changes these to their defaults. + + # Here are the official names of the properties, in a parallel array: + my @field_names; + $field_names[$BIDI] = 'Bidi_Class'; + $field_names[$CATEGORY] = 'General_Category'; + $field_names[$CCC] = 'Canonical_Combining_Class'; + $field_names[$COMMENT] = 'ISO_Comment'; + $field_names[$DECOMP_MAP] = 'Decomposition_Mapping'; + $field_names[$DECOMP_TYPE] = 'Decomposition_Type'; + $field_names[$LOWER] = 'Simple_Lowercase_Mapping'; + $field_names[$MIRRORED] = 'Bidi_Mirrored'; + $field_names[$NAME] = 'Name'; + $field_names[$NUMERIC] = 'Numeric_Value'; + $field_names[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric_Type'; + $field_names[$PERL_DECIMAL_DIGIT] = 'Perl_Decimal_Digit'; + $field_names[$PERL_DECOMPOSITION] = 'Perl_Decomposition_Mapping'; + $field_names[$TITLE] = 'Simple_Titlecase_Mapping'; + $field_names[$UNICODE_1_NAME] = 'Unicode_1_Name'; + $field_names[$UPPER] = 'Simple_Uppercase_Mapping'; + + # Some of these need a little more explanation. The $PERL_DECIMAL_DIGIT + # field does not lead to an official Unicode property, but is used in + # calculating the Numeric_Type. Perl however, creates a file from this + # field, so a Perl property is created from it. Similarly, the Other + # Digit field is used only for calculating the Numeric_Type, and so it can + # be safely re-used as the place to store the value for Numeric_Type; + # hence it is referred to as $NUMERIC_TYPE_OTHER_DIGIT. The input field + # named $PERL_DECOMPOSITION is a combination of both the decomposition + # mapping and its type. Perl creates a file containing exactly this + # field, so it is used for that. The two properties are separated into + # two extra output fields, $DECOMP_MAP and $DECOMP_TYPE. + + # This file is processed like most in this program. Control is passed to + # process_generic_property_file() which calls filter_UnicodeData_line() + # for each input line. This filter converts the input into line(s) that + # process_generic_property_file() understands. There is also a setup + # routine called before any of the file is processed, and a handler for + # EOF processing, all in this closure. + + # A huge speed-up occurred at the cost of some added complexity when these + # routines were altered to buffer the outputs into ranges. Almost all the + # lines of the input file apply to just one code point, and for most + # properties, the map for the next code point up is the same as the + # current one. So instead of creating a line for each property for each + # input line, filter_UnicodeData_line() remembers what the previous map + # of a property was, and doesn't generate a line to pass on until it has + # to, as when the map changes; and that passed-on line encompasses the + # whole contiguous range of code points that have the same map for that + # property. This means a slight amount of extra setup, and having to + # flush these buffers on EOF, testing if the maps have changed, plus + # remembering state information in the closure. But it means a lot less + # real time in not having to change the data base for each property on + # each line. + + # Another complication is that there are already a few ranges designated + # in the input. There are two lines for each, with the same maps except + # the code point and name on each line. This was actually the hardest + # thing to design around. The code points in those ranges may actually + # have real maps not given by these two lines. These maps will either + # be algorthimically determinable, or in the extracted files furnished + # with the UCD. In the event of conflicts between these extracted files, + # and this one, Unicode says that this one prevails. But it shouldn't + # prevail for conflicts that occur in these ranges. The data from the + # extracted files prevails in those cases. So, this program is structured + # so that those files are processed first, storing maps. Then the other + # files are processed, generally overwriting what the extracted files + # stored. But just the range lines in this input file are processed + # without overwriting. This is accomplished by adding a special string to + # the lines output to tell process_generic_property_file() to turn off the + # overwriting for just this one line. + # A similar mechanism is used to tell it that the map is of a non-default + # type. + + sub setup_UnicodeData { # Called before any lines of the input are read + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $Perl_decomp = Property->new('Perl_Decomposition_Mapping', + Directory => '.', + File => 'Decomposition', + Format => $STRING_FORMAT, + Internal_Only_Warning => 1, + Perl_Extension => 1, + Default_Map => $CODE_POINT, + + # This is a specially formatted table + # explicitly for normalize.pm, which + # is expecting a particular format, + # which means that mappings containing + # multiple code points are in the main + # body of the table + Map_Type => $COMPUTE_NO_MULTI_CP, + Type => $STRING, + ); + $Perl_decomp->add_comment(join_lines(<<END +This mapping is a combination of the Unicode 'Decomposition_Type' and +'Decomposition_Mapping' properties, formatted for use by normalize.pm. It is +identical to the official Unicode 'Decomposition_Mapping' property except for +two things: + 1) It omits the algorithmically determinable Hangul syllable decompositions, +which normalize.pm handles algorithmically. + 2) It contains the decomposition type as well. Non-canonical decompositions +begin with a word in angle brackets, like <super>, which denotes the +compatible decomposition type. If the map does not begin with the <angle +brackets>, the decomposition is canonical. +END + )); + + my $Decimal_Digit = Property->new("Perl_Decimal_Digit", + Default_Map => "", + Perl_Extension => 1, + File => 'Digit', # Trad. location + Directory => $map_directory, + Type => $STRING, + Range_Size_1 => 1, + ); + $Decimal_Digit->add_comment(join_lines(<<END +This file gives the mapping of all code points which represent a single +decimal digit [0-9] to their respective digits. For example, the code point +U+0031 (an ASCII '1') is mapped to a numeric 1. These code points are those +that have Numeric_Type=Decimal; not special things, like subscripts nor Roman +numerals. +END + )); + + # This property is not used for generating anything else, and is + # usually not output. By making it last in the list, we can just + # change the high end of the loop downwards to avoid the work of + # generating a table that is just going to get thrown away. + if (! property_ref('Decomposition_Mapping')->to_output_map) { + $last_field--; + } + return; } - close IN; - # Now append the scripts properties in their code point order. + my $first_time = 1; # ? Is this the first line of the file + my $in_range = 0; # ? Are we in one of the file's ranges + my $previous_cp; # hex code point of previous line + my $decimal_previous_cp = -1; # And its decimal equivalent + my @start; # For each field, the current starting + # code point in hex for the range + # being accumulated. + my @fields; # The input fields; + my @previous_fields; # And those from the previous call + + sub filter_UnicodeData_line { + # Handle a single input line from UnicodeData.txt; see comments above + # Conceptually this takes a single line from the file containing N + # properties, and converts it into N lines with one property per line, + # which is what the final handler expects. But there are + # complications due to the quirkiness of the input file, and to save + # time, it accumulates ranges where the property values don't change + # and only emits lines when necessary. This is about an order of + # magnitude fewer lines emitted. + + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # $_ contains the input line. + # -1 in split means retain trailing null fields + (my $cp, @fields) = split /\s*;\s*/, $_, -1; + + #local $to_trace = 1 if main::DEBUG; + trace $cp, @fields , $input_field_count if main::DEBUG && $to_trace; + if (@fields > $input_field_count) { + $file->carp_bad_line('Extra fields'); + $_ = ""; + return; + } - my %Script; - my $Scripts = Table->New(); + my $decimal_cp = hex $cp; + + # We have to output all the buffered ranges when the next code point + # is not exactly one after the previous one, which means there is a + # gap in the ranges. + my $force_output = ($decimal_cp != $decimal_previous_cp + 1); + + # The decomposition mapping field requires special handling. It looks + # like either: + # + # <compat> 0032 0020 + # 0041 0300 + # + # The decomposition type is enclosed in <brackets>; if missing, it + # means the type is canonical. There are two decomposition mapping + # tables: the one for use by Perl's normalize.pm has a special format + # which is this field intact; the other, for general use is of + # standard format. In either case we have to find the decomposition + # type. Empty fields have None as their type, and map to the code + # point itself + if ($fields[$PERL_DECOMPOSITION] eq "") { + $fields[$DECOMP_TYPE] = 'None'; + $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION] = $CODE_POINT; + } + else { + ($fields[$DECOMP_TYPE], my $map) = $fields[$PERL_DECOMPOSITION] + =~ / < ( .+? ) > \s* ( .+ ) /x; + if (! defined $fields[$DECOMP_TYPE]) { + $fields[$DECOMP_TYPE] = 'Canonical'; + $fields[$DECOMP_MAP] = $fields[$PERL_DECOMPOSITION]; + } + else { + $fields[$DECOMP_MAP] = $map; + } + } - for my $script (sort { $a->[0] <=> $b->[0] } @ScriptInfo) - { - my ($first, $last, $name) = @$script; - $Scripts->Append($first, $name); + # The 3 numeric fields also require special handling. The 2 digit + # fields must be either empty or match the number field. This means + # that if it is empty, they must be as well, and the numeric type is + # None, and the numeric value is 'Nan'. + # The decimal digit field must be empty or match the other digit + # field. If the decimal digit field is non-empty, the code point is + # a decimal digit, and the other two fields will have the same value. + # If it is empty, but the other digit field is non-empty, the code + # point is an 'other digit', and the number field will have the same + # value as the other digit field. If the other digit field is empty, + # but the number field is non-empty, the code point is a generic + # numeric type. + if ($fields[$NUMERIC] eq "") { + if ($fields[$PERL_DECIMAL_DIGIT] ne "" + || $fields[$NUMERIC_TYPE_OTHER_DIGIT] ne "" + ) { + $file->carp_bad_line("Numeric values inconsistent. Trying to process anyway"); + } + $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'None'; + $fields[$NUMERIC] = 'NaN'; + } + else { + $file->carp_bad_line("'$fields[$NUMERIC]' should be a whole or rational number. Processing as if it were") if $fields[$NUMERIC] !~ qr{ ^ -? \d+ ( / \d+ )? $ }x; + if ($fields[$PERL_DECIMAL_DIGIT] ne "") { + $file->carp_bad_line("$fields[$PERL_DECIMAL_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$PERL_DECIMAL_DIGIT] != $fields[$NUMERIC]; + $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Decimal'; + } + elsif ($fields[$NUMERIC_TYPE_OTHER_DIGIT] ne "") { + $file->carp_bad_line("$fields[$NUMERIC_TYPE_OTHER_DIGIT] should equal $fields[$NUMERIC]. Processing anyway") if $fields[$NUMERIC_TYPE_OTHER_DIGIT] != $fields[$NUMERIC]; + $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Digit'; + } + else { + $fields[$NUMERIC_TYPE_OTHER_DIGIT] = 'Numeric'; + + # Rationals require extra effort. + register_fraction($fields[$NUMERIC]) + if $fields[$NUMERIC] =~ qr{/}; + } + } - $Script{$name} ||= Table->New(Is => $name, - Desc => "Script '$name'", - Fuzzy => 1); - $Script{$name}->Append($first, $name); + # For the properties that have empty fields in the file, and which + # mean something different from empty, change them to that default. + # Certain fields just haven't been empty so far in any Unicode + # version, so don't look at those, namely $MIRRORED, $BIDI, $CCC, + # $CATEGORY. This leaves just the two fields, and so we hard-code in + # the defaults; which are verly unlikely to ever change. + $fields[$UPPER] = $CODE_POINT if $fields[$UPPER] eq ""; + $fields[$LOWER] = $CODE_POINT if $fields[$LOWER] eq ""; + + # UAX44 says that if title is empty, it is the same as whatever upper + # is, + $fields[$TITLE] = $fields[$UPPER] if $fields[$TITLE] eq ""; + + # There are a few pairs of lines like: + # AC00;<Hangul Syllable, First>;Lo;0;L;;;;;N;;;;; + # D7A3;<Hangul Syllable, Last>;Lo;0;L;;;;;N;;;;; + # that define ranges. These should be processed after the fields are + # adjusted above, as they may override some of them; but mostly what + # is left is to possibly adjust the $NAME field. The names of all the + # paired lines start with a '<', but this is also true of '<control>, + # which isn't one of these special ones. + if ($fields[$NAME] eq '<control>') { + + # Some code points in this file have the pseudo-name + # '<control>', but the official name for such ones is the null + # string. + $fields[$NAME] = ""; + + # We had better not be in between range lines. + if ($in_range) { + $file->carp_bad_line("Expecting a closing range line, not a $fields[$NAME]'. Trying anyway"); + $in_range = 0; + } + } + elsif (substr($fields[$NAME], 0, 1) ne '<') { + + # Here is a non-range line. We had better not be in between range + # lines. + if ($in_range) { + $file->carp_bad_line("Expecting a closing range line, not a $fields[$NAME]'. Trying anyway"); + $in_range = 0; + } + # XXX until charnames catches up. +# if ($fields[$NAME] =~ s/- $cp $//x) { +# +# # These are code points whose names end in their code points, +# # which means the names are algorithmically derivable from the +# # code points. To shorten the output Name file, the algorithm +# # for deriving these is placed in the file instead of each +# # code point, so they have map type $CP_IN_NAME +# $fields[$NAME] = $CMD_DELIM +# . $MAP_TYPE_CMD +# . '=' +# . $CP_IN_NAME +# . $CMD_DELIM +# . $fields[$NAME]; +# } + + # Some official names are really two alternate names with one in + # parentheses. What we do here is use the full official one for + # the standard property (stored just above), but for the charnames + # table, we add two more entries, one for each of the alternate + # ones. + # elsif name ne "" + #check_and_handle_compound_name($cp, $fields[$NAME]); + #check_and_handle_compound_name($cp, $unicode_1_name); + # XXX until charnames catches up. + } + elsif ($fields[$NAME] =~ /^<(.+), First>$/) { + $fields[$NAME] = $1; + + # Here we are at the beginning of a range pair. + if ($in_range) { + $file->carp_bad_line("Expecting a closing range line, not a beginning one, $fields[$NAME]'. Trying anyway"); + } + $in_range = 1; + + # Because the properties in the range do not overwrite any already + # in the db, we must flush the buffers of what's already there, so + # they get handled in the normal scheme. + $force_output = 1; - if ($last) { - $Scripts->Extend($last); - $Script{$name}->Extend($last); } + elsif ($fields[$NAME] !~ s/^<(.+), Last>$/$1/) { + $file->carp_bad_line("Unexpected name starting with '<' $fields[$NAME]. Ignoring this line."); + $_ = ""; + return; + } + else { # Here, we are at the last line of a range pair. + + if (! $in_range) { + $file->carp_bad_line("Unexpected end of range $fields[$NAME] when not in one. Ignoring this line."); + $_ = ""; + return; + } + $in_range = 0; + + # Check that the input is valid: that the closing of the range is + # the same as the beginning. + foreach my $i (0 .. $last_field) { + next if $fields[$i] eq $previous_fields[$i]; + $file->carp_bad_line("Expecting '$fields[$i]' to be the same as '$previous_fields[$i]'. Bad News. Trying anyway"); + } + + # The processing differs depending on the type of range, + # determined by its $NAME + if ($fields[$NAME] =~ /^Hangul Syllable/) { + + # Check that the data looks right. + if ($decimal_previous_cp != $SBase) { + $file->carp_bad_line("Unexpected Hangul syllable start = $previous_cp. Bad News. Results will be wrong"); + } + if ($decimal_cp != $SBase + $SCount - 1) { + $file->carp_bad_line("Unexpected Hangul syllable end = $cp. Bad News. Results will be wrong"); + } + + # The Hangul syllable range has a somewhat complicated name + # generation algorithm. Each code point in it has a canonical + # decomposition also computable by an algorithm. The + # perl decomposition map table built from these is used only + # by normalize.pm, which has the algorithm built in it, so the + # decomposition maps are not needed, and are large, so are + # omitted from it. If the full decomposition map table is to + # be output, the decompositions are generated for it, in the + # EOF handling code for this input file. + + $previous_fields[$DECOMP_TYPE] = 'Canonical'; + + # This range is stored in our internal structure with its + # own map type, different from all others. + $previous_fields[$NAME] = $CMD_DELIM + . $MAP_TYPE_CMD + . '=' + . $HANGUL_SYLLABLE + . $CMD_DELIM + . $fields[$NAME]; + } + elsif ($fields[$NAME] =~ /^CJK/) { + + # The name for these contains the code point itself, and all + # are defined to have the same base name, regardless of what + # is in the file. They are stored in our internal structure + # with a map type of $CP_IN_NAME + $previous_fields[$NAME] = $CMD_DELIM + . $MAP_TYPE_CMD + . '=' + . $CP_IN_NAME + . $CMD_DELIM + . 'CJK UNIFIED IDEOGRAPH'; + + } + elsif ($fields[$CATEGORY] eq 'Co' + || $fields[$CATEGORY] eq 'Cs') + { + # The names of all the code points in these ranges are set to + # null, as there are no names for the private use and + # surrogate code points. + + $previous_fields[$NAME] = ""; + } + else { + $file->carp_bad_line("Unexpected code point range $fields[$NAME] because category is $fields[$CATEGORY]. Attempting to process it."); + } + + # The first line of the range caused everything else to be output, + # and then its values were stored as the beginning values for the + # next set of ranges, which this one ends. Now, for each value, + # add a command to tell the handler that these values should not + # replace any existing ones in our database. + foreach my $i (0 .. $last_field) { + $previous_fields[$i] = $CMD_DELIM + . $REPLACE_CMD + . '=' + . $NO + . $CMD_DELIM + . $previous_fields[$i]; + } + + # And change things so it looks like the entire range has been + # gone through with this being the final part of it. Adding the + # command above to each field will cause this range to be flushed + # during the next iteration, as it guaranteed that the stored + # field won't match whatever value the next one has. + $previous_cp = $cp; + $decimal_previous_cp = $decimal_cp; + + # We are now set up for the next iteration; so skip the remaining + # code in this subroutine that does the same thing, but doesn't + # know about these ranges. + $_ = ""; + return; + } + + # On the very first line, we fake it so the code below thinks there is + # nothing to output, and initialize so that when it does get output it + # uses the first line's values for the lowest part of the range. + # (One could avoid this by using peek(), but then one would need to + # know the adjustments done above and do the same ones in the setup + # routine; not worth it) + if ($first_time) { + $first_time = 0; + @previous_fields = @fields; + @start = ($cp) x scalar @fields; + $decimal_previous_cp = $decimal_cp - 1; + } + + # For each field, output the stored up ranges that this code point + # doesn't fit in. Earlier we figured out if all ranges should be + # terminated because of changing the replace or map type styles, or if + # there is a gap between this new code point and the previous one, and + # that is stored in $force_output. But even if those aren't true, we + # need to output the range if this new code point's value for the + # given property doesn't match the stored range's. + #local $to_trace = 1 if main::DEBUG; + foreach my $i (0 .. $last_field) { + my $field = $fields[$i]; + if ($force_output || $field ne $previous_fields[$i]) { + + # Flush the buffer of stored values. + $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]"); + + # Start a new range with this code point and its value + $start[$i] = $cp; + $previous_fields[$i] = $field; + } + } + + # Set the values for the next time. + $previous_cp = $cp; + $decimal_previous_cp = $decimal_cp; + + # The input line has generated whatever adjusted lines are needed, and + # should not be looked at further. + $_ = ""; + return; + } + + sub EOF_UnicodeData { + # Called upon EOF to flush the buffers, and create the Hangul + # decomposition mappings if needed. + + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # Flush the buffers. + foreach my $i (1 .. $last_field) { + $file->insert_adjusted_lines("$start[$i]..$previous_cp; $field_names[$i]; $previous_fields[$i]"); + } + + if (-e 'Jamo.txt') { + + # The algorithm is published by Unicode, based on values in + # Jamo.txt, (which should have been processed before this + # subroutine), and the results left in %Jamo + unless (%Jamo) { + Carp::my_carp_bug("Jamo.txt should be processed before Unicode.txt. Hangul syllables not generated."); + return; + } + + # If the full decomposition map table is being output, insert + # into it the Hangul syllable mappings. This is to avoid having + # to publish a subroutine in it to compute them. (which would + # essentially be this code.) This uses the algorithm published by + # Unicode. + if (property_ref('Decomposition_Mapping')->to_output_map) { + for (my $S = $SBase; $S < $SBase + $SCount; $S++) { + use integer; + my $SIndex = $S - $SBase; + my $L = $LBase + $SIndex / $NCount; + my $V = $VBase + ($SIndex % $NCount) / $TCount; + my $T = $TBase + $SIndex % $TCount; + + trace "L=$L, V=$V, T=$T" if main::DEBUG && $to_trace; + my $decomposition = sprintf("%04X %04X", $L, $V); + $decomposition .= sprintf(" %04X", $T) if $T != $TBase; + $file->insert_adjusted_lines( + sprintf("%04X; Decomposition_Mapping; %s", + $S, + $decomposition)); + } + } + } + + return; + } + + sub filter_v1_ucd { + # Fix UCD lines in version 1. This is probably overkill, but this + # fixes some glaring errors in Version 1 UnicodeData.txt. That file: + # 1) had many Hangul (U+3400 - U+4DFF) code points that were later + # removed. This program retains them + # 2) didn't include ranges, which it should have, and which are now + # added in @corrected_lines below. It was hand populated by + # taking the data from Version 2, verified by analyzing + # DAge.txt. + # 3) There is a syntax error in the entry for U+09F8 which could + # cause problems for utf8_heavy, and so is changed. It's + # numeric value was simply a minus sign, without any number. + # (Eventually Unicode changed the code point to non-numeric.) + # 4) The decomposition types often don't match later versions + # exactly, and the whole syntax of that field is different; so + # the syntax is changed as well as the types to their later + # terminology. Otherwise normalize.pm would be very unhappy + # 5) Many ccc classes are different. These are left intact. + # 6) U+FF10 - U+FF19 are missing their numeric values in all three + # fields. These are unchanged because it doesn't really cause + # problems for Perl. + # 7) A number of code points, such as controls, don't have their + # Unicode Version 1 Names in this file. These are unchanged. + + my @corrected_lines = split /\n/, <<'END'; +4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;; +9FA5;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;; +E000;<Private Use, First>;Co;0;L;;;;;N;;;;; +F8FF;<Private Use, Last>;Co;0;L;;;;;N;;;;; +F900;<CJK Compatibility Ideograph, First>;Lo;0;L;;;;;N;;;;; +FA2D;<CJK Compatibility Ideograph, Last>;Lo;0;L;;;;;N;;;;; +END + + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + #local $to_trace = 1 if main::DEBUG; + trace $_ if main::DEBUG && $to_trace; + + # -1 => retain trailing null fields + my ($code_point, @fields) = split /\s*;\s*/, $_, -1; + + # At the first place that is wrong in the input, insert all the + # corrections, replacing the wrong line. + if ($code_point eq '4E00') { + my @copy = @corrected_lines; + $_ = shift @copy; + ($code_point, @fields) = split /\s*;\s*/, $_, -1; + + $file->insert_lines(@copy); + } + + + if ($fields[$NUMERIC] eq '-') { + $fields[$NUMERIC] = '-1'; # This is what 2.0 made it. + } + + if ($fields[$PERL_DECOMPOSITION] ne "") { + + # Several entries have this change to superscript 2 or 3 in the + # middle. Convert these to the modern version, which is to use + # the actual U+00B2 and U+00B3 (the superscript forms) instead. + # So 'HHHH HHHH <+sup> 0033 <-sup> HHHH' becomes + # 'HHHH HHHH 00B3 HHHH'. + # It turns out that all of these that don't have another + # decomposition defined at the beginning of the line have the + # <square> decomposition in later releases. + if ($code_point ne '00B2' && $code_point ne '00B3') { + if ($fields[$PERL_DECOMPOSITION] + =~ s/<\+sup> 003([23]) <-sup>/00B$1/) + { + if (substr($fields[$PERL_DECOMPOSITION], 0, 1) ne '<') { + $fields[$PERL_DECOMPOSITION] = '<square> ' + . $fields[$PERL_DECOMPOSITION]; + } + } + } + + # If is like '<+circled> 0052 <-circled>', convert to + # '<circled> 0052' + $fields[$PERL_DECOMPOSITION] =~ + s/ < \+ ( .*? ) > \s* (.*?) \s* <-\1> /<$1> $2/x; + + # Convert '<join> HHHH HHHH <join>' to '<medial> HHHH HHHH', etc. + $fields[$PERL_DECOMPOSITION] =~ + s/ <join> \s* (.*?) \s* <no-join> /<final> $1/x + or $fields[$PERL_DECOMPOSITION] =~ + s/ <join> \s* (.*?) \s* <join> /<medial> $1/x + or $fields[$PERL_DECOMPOSITION] =~ + s/ <no-join> \s* (.*?) \s* <join> /<initial> $1/x + or $fields[$PERL_DECOMPOSITION] =~ + s/ <no-join> \s* (.*?) \s* <no-join> /<isolated> $1/x; + + # Convert '<break> HHHH HHHH <break>' to '<break> HHHH', etc. + $fields[$PERL_DECOMPOSITION] =~ + s/ <(break|no-break)> \s* (.*?) \s* <\1> /<$1> $2/x; + + # Change names to modern form. + $fields[$PERL_DECOMPOSITION] =~ s/<font variant>/<font>/g; + $fields[$PERL_DECOMPOSITION] =~ s/<no-break>/<noBreak>/g; + $fields[$PERL_DECOMPOSITION] =~ s/<circled>/<circle>/g; + $fields[$PERL_DECOMPOSITION] =~ s/<break>/<fraction>/g; + + # One entry has weird braces + $fields[$PERL_DECOMPOSITION] =~ s/[{}]//g; + } + + $_ = join ';', $code_point, @fields; + trace $_ if main::DEBUG && $to_trace; + return; + } + + sub filter_v2_1_5_ucd { + # A dozen entries in this 2.1.5 file had the mirrored and numeric + # columns swapped; These all had mirrored be 'N'. So if the numeric + # column appears to be N, swap it back. + + my ($code_point, @fields) = split /\s*;\s*/, $_, -1; + if ($fields[$NUMERIC] eq 'N') { + $fields[$NUMERIC] = $fields[$MIRRORED]; + $fields[$MIRRORED] = 'N'; + $_ = join ';', $code_point, @fields; + } + return; } +} # End closure for UnicodeData - # $Scripts->Write("Scripts.pl"); +sub process_NamedSequences { + # NamedSequences.txt entries are just added to an array. Because these + # don't look like the other tables, they have their own handler. + # An example: + # LATIN CAPITAL LETTER A WITH MACRON AND GRAVE;0100 0300 + # + # This just adds the sequence to an array for later handling + + return; # XXX Until charnames catches up + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; - ## Common is everything not explicitly assigned to a Script - ## - ## ***shouldn't this be intersected with \p{Assigned}? ****** - ## - New_Prop(Is => 'Common', - $Scripts->Invert, - Desc => 'Pseudo-Script of codepoints not in other Unicode scripts', - Fuzzy => 1); + while ($file->next_line) { + my ($name, $sequence, @remainder) = split /\s*;\s*/, $_, -1; + if (@remainder) { + $file->carp_bad_line( + "Doesn't look like 'KHMER VOWEL SIGN OM;17BB 17C6'"); + next; + } + push @named_sequences, "$sequence\t\t$name"; + } + return; } -## -## Given a name like "Close Punctuation", return a regex (that when applied -## with /i) matches any valid form of that name (e.g. "ClosePunctuation", -## "Close-Punctuation", etc.) -## -## Accept any space, dash, or underbar where in the official name there is -## space or a dash (or underbar, but there never is). -## -## -sub NameToRegex($) -{ - my $Name = shift; - $Name =~ s/[- _]/(?:[-_]|\\s+)?/g; - return $Name; +{ # Closure + + my $first_range; + + sub filter_early_ea_lb { + # Fixes early EastAsianWidth.txt and LineBreak.txt files. These had a + # third field be the name of the code point, which can be ignored in + # most cases. But it can be meaningful if it marks a range: + # 33FE;W;IDEOGRAPHIC TELEGRAPH SYMBOL FOR DAY THIRTY-ONE + # 3400;W;<CJK Ideograph Extension A, First> + # + # We need to see the First in the example above to know it's a range. + # They did not use the later range syntaxes. This routine changes it + # to use the modern syntax. + # $1 is the Input_file object. + + my @fields = split /\s*;\s*/; + if ($fields[2] =~ /^<.*, First>/) { + $first_range = $fields[0]; + $_ = ""; + } + elsif ($fields[2] =~ /^<.*, Last>/) { + $_ = $_ = "$first_range..$fields[0]; $fields[1]"; + } + else { + undef $first_range; + $_ = "$fields[0]; $fields[1]"; + } + + return; + } +} + +sub filter_old_style_arabic_shaping { + # Early versions used a different term for the later one. + + my @fields = split /\s*;\s*/; + $fields[3] =~ s/<no shaping>/No_Joining_Group/; + $fields[3] =~ s/\s+/_/g; # Change spaces to underscores + $_ = join ';', @fields; + return; } -## -## Process Blocks.txt. -## -sub Blocks_txt() -{ - my $Blocks = Table->New(); - my %Blocks; +sub filter_arabic_shaping_line { + # ArabicShaping.txt has entries that look like: + # 062A; TEH; D; BEH + # The field containing 'TEH' is not used. The next field is Joining_Type + # and the last is Joining_Group + # This generates two lines to pass on, one for each property on the input + # line. - if (not open IN, "Blocks.txt") { - die "$0: Blocks.txt: $!\n"; + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields + + if (@fields > 4) { + $file->carp_bad_line('Extra fields'); + $_ = ""; + return; } - while (<IN>) - { - #next if not /Private Use$/; - next if not /^([0-9A-Fa-f]+)\.\.([0-9A-Fa-f]+)\s*;\s*(.+?)\s*$/; + $file->insert_adjusted_lines("$fields[0]; Joining_Group; $fields[3]"); + $_ = "$fields[0]; Joining_Type; $fields[2]"; + + return; +} + +sub setup_special_casing { + # SpecialCasing.txt contains the non-simple case change mappings. The + # simple ones are in UnicodeData.txt, and should already have been read + # in. + # This routine initializes the full mappings to the simple, then as each + # line is processed, it overrides the simple ones. - my ($first, $last, $name) = (hex($1), hex($2), $3); + my $file= shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; - $Blocks->Append($first, $name); + # For each of the case change mappings... + foreach my $case ('lc', 'tc', 'uc') { - $Blocks{$name} ||= Table->New(In => $name, - Desc => "Block '$name'", - Fuzzy => 1); - $Blocks{$name}->Append($first, $name); + # The simple version's name in each mapping merely has an 's' in front + # of the full one's + my $simple = property_ref('s' . $case); + unless (defined $simple && ! $simple->is_empty) { + Carp::my_carp_bug("Need to process UnicodeData before SpecialCasing. Only special casing will be generated."); + } - if ($last and $last != $first) { - $Blocks->Extend($last); - $Blocks{$name}->Extend($last); - } + # Initialize the full case mappings with the simple ones. + property_ref($case)->initialize($simple); } - close IN; - # $Blocks->Write("Blocks.pl"); + return; } -## -## Read in the PropList.txt. It contains extended properties not -## listed in the UnicodeData.txt, such as 'Other_Alphabetic': -## alphabetic but not of the general category L; many modifiers -## belong to this extended property category: while they are not -## alphabets, they are alphabetic in nature. -## -sub PropList_txt() -{ - my @PropInfo; +sub filter_special_casing_line { + # Change the format of $_ from SpecialCasing.txt into something that the + # generic handler understands. Each input line contains three case + # mappings. This will generate three lines to pass to the generic handler + # for each of those. + + # The input syntax (after stripping comments and trailing white space is + # like one of the following (with the final two being entries that we + # ignore): + # 00DF; 00DF; 0053 0073; 0053 0053; # LATIN SMALL LETTER SHARP S + # 03A3; 03C2; 03A3; 03A3; Final_Sigma; + # 0307; ; 0307; 0307; tr After_I; # COMBINING DOT ABOVE + # Note the trailing semi-colon, unlike many of the input files. That + # means that there will be an extra null field generated by the split + + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields + + # field #4 is when this mapping is conditional. If any of these get + # implemented, it would be by hard-coding in the casing functions in the + # Perl core, not through tables. But if there is a new condition we don't + # know about, output a warning. We know about all the conditions through + # 5.2 + if ($fields[4] ne "") { + my @conditions = split ' ', $fields[4]; + if ($conditions[0] ne 'tr' # We know that these languages have + # conditions, and some are multiple + && $conditions[0] ne 'az' + && $conditions[0] ne 'lt' + + # And, we know about a single condition Final_Sigma, but + # nothing else. + && ($v_version gt v5.2.0 + && (@conditions > 1 || $conditions[0] ne 'Final_Sigma'))) + { + $file->carp_bad_line("Unknown condition '$fields[4]'. You should inspect it and either add code to handle it, or add to list of those that are to ignore"); + } + elsif ($conditions[0] ne 'Final_Sigma') { - if (not open IN, "PropList.txt") { - die "$0: PropList.txt: $!\n"; + # Don't print out a message for Final_Sigma, because we have + # hard-coded handling for it. (But the standard could change + # what the rule should be, but it wouldn't show up here + # anyway. + + print "# SKIPPING Special Casing: $_\n" + if $verbosity >= $VERBOSE; + } + $_ = ""; + return; + } + elsif (@fields > 6 || (@fields == 6 && $fields[5] ne "" )) { + $file->carp_bad_line('Extra fields'); + $_ = ""; + return; } - while (<IN>) - { - next unless /^([0-9A-Fa-f]+)(?:\.\.([0-9A-Fa-f]+))?\s*;\s*(.+?)\s*\#/; + $_ = "$fields[0]; lc; $fields[1]"; + $file->insert_adjusted_lines("$fields[0]; tc; $fields[2]"); + $file->insert_adjusted_lines("$fields[0]; uc; $fields[3]"); - # Wait until all the extended properties have been read since - # they are not listed in numeric order. - push @PropInfo, [ hex($1), hex($2||""), $3 ]; + return; +} + +sub filter_old_style_case_folding { + # This transforms $_ containing the case folding style of 3.0.1, to 3.1 + # and later style. Different letters were used in the earlier. + + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my @fields = split /\s*;\s*/; + if ($fields[0] =~ /^ 013 [01] $/x) { # The two turkish fields + $fields[1] = 'I'; + } + elsif ($fields[1] eq 'L') { + $fields[1] = 'C'; # L => C always + } + elsif ($fields[1] eq 'E') { + if ($fields[2] =~ / /) { # E => C if one code point; F otherwise + $fields[1] = 'F' + } + else { + $fields[1] = 'C' + } + } + else { + $file->carp_bad_line("Expecting L or E in second field"); + $_ = ""; + return; } - close IN; + $_ = join("; ", @fields) . ';'; + return; +} - # Now append the extended properties in their code point order. - my $Props = Table->New(); - my %Prop; +{ # Closure for case folding - for my $prop (sort { $a->[0] <=> $b->[0] } @PropInfo) - { - my ($first, $last, $name) = @$prop; - $Props->Append($first, $name); - - $Prop{$name} ||= Table->New(Is => $name, - Desc => "Extended property '$name'", - Fuzzy => 1); - $Prop{$name}->Append($first, $name); - - if ($last) { - $Props->Extend($last); - $Prop{$name}->Extend($last); - } - } - - for (keys %Prop) { - (my $file = $PA_reverse{$_}) =~ tr/_//d; - # XXX I'm assuming that the names from %Prop don't suffer 8.3 clashes. - $BaseNames{lc $file}++; - $Prop{$_}->Write( - ["lib","gc_sc","$file.pl"], - "Binary property '$_'" - ); - } - - # Alphabetic is L, Nl, and Other_Alphabetic. - New_Prop(Is => 'Alphabetic', - Table->Merge($Cat{L}, $Cat{Nl}, $Prop{Other_Alphabetic}), - Desc => '[\p{L}\p{Nl}\p{OtherAlphabetic}]', # canonical names - Fuzzy => 1); - - # Lowercase is Ll and Other_Lowercase. - New_Prop(Is => 'Lowercase', - Table->Merge($Cat{Ll}, $Prop{Other_Lowercase}), - Desc => '[\p{Ll}\p{OtherLowercase}]', # canonical names - Fuzzy => 1); - - # Uppercase is Lu and Other_Uppercase. - New_Prop(Is => 'Uppercase', - Table->Merge($Cat{Lu}, $Prop{Other_Uppercase}), - Desc => '[\p{Lu}\p{OtherUppercase}]', # canonical names - Fuzzy => 1); - - # Math is Sm and Other_Math. - New_Prop(Is => 'Math', - Table->Merge($Cat{Sm}, $Prop{Other_Math}), - Desc => '[\p{Sm}\p{OtherMath}]', # canonical names - Fuzzy => 1); - - # ID_Start is Ll, Lu, Lt, Lm, Lo, Nl, and Other_ID_Start. - New_Prop(Is => 'ID_Start', - Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl]}, $Prop{Other_ID_Start}), - Desc => '[\p{Ll}\p{Lu}\p{Lt}\p{Lm}\p{Lo}\p{Nl}\p{OtherIDStart}]', - Fuzzy => 1); - - # ID_Continue is ID_Start, Mn, Mc, Nd, Pc, and Other_ID_Continue. - New_Prop(Is => 'ID_Continue', - Table->Merge(@Cat{qw[Ll Lu Lt Lm Lo Nl Mn Mc Nd Pc ]}, - @Prop{qw[Other_ID_Start Other_ID_Continue]}), - Desc => '[\p{ID_Start}\p{Mn}\p{Mc}\p{Nd}\p{Pc}\p{OtherIDContinue}]', - Fuzzy => 1); - - # Default_Ignorable_Code_Point = Other_Default_Ignorable_Code_Point - # + Cf + Cc + Cs + Noncharacter + Variation_Selector - # - WhiteSpace - FFF9..FFFB (Annotation Characters) - - my $Annotation = Table->New(); - $Annotation->RawAppendRange(0xFFF9, 0xFFFB); - - New_Prop(Is => 'Default_Ignorable_Code_Point', - Table->Merge(@Cat{qw[Cf Cc Cs]}, - $Prop{Noncharacter_Code_Point}, - $Prop{Variation_Selector}, - $Prop{Other_Default_Ignorable_Code_Point}) - ->Invert - ->Merge($Prop{White_Space}, $Annotation) - ->Invert, - Desc => '(?![\p{WhiteSpace}\x{FFF9}-\x{FFFB}])[\p{Cf}\p{Cc}'. - '\p{Cs}\p{NoncharacterCodePoint}\p{VariationSelector}'. - '\p{OtherDefaultIgnorableCodePoint}]', - Fuzzy => 1); - -} - - -## -## These are used in: -## MakePropTestScript() -## WriteAllMappings() -## for making the test script. -## -my %FuzzyNameToTest; -my %ExactNameToTest; - - -## This used only for making the test script -sub GenTests($$$$) -{ - my $FH = shift; - my $Prop = shift; - my $MatchCode = shift; - my $FailCode = shift; - - if (defined $MatchCode) { - printf $FH qq/Expect(1, "\\x{%04X}", '\\p{$Prop}' );\n/, $MatchCode; - printf $FH qq/Expect(0, "\\x{%04X}", '\\p{^$Prop}');\n/, $MatchCode; - printf $FH qq/Expect(0, "\\x{%04X}", '\\P{$Prop}' );\n/, $MatchCode; - printf $FH qq/Expect(1, "\\x{%04X}", '\\P{^$Prop}');\n/, $MatchCode; - } - if (defined $FailCode) { - printf $FH qq/Expect(0, "\\x{%04X}", '\\p{$Prop}' );\n/, $FailCode; - printf $FH qq/Expect(1, "\\x{%04X}", '\\p{^$Prop}');\n/, $FailCode; - printf $FH qq/Expect(1, "\\x{%04X}", '\\P{$Prop}' );\n/, $FailCode; - printf $FH qq/Expect(0, "\\x{%04X}", '\\P{^$Prop}');\n/, $FailCode; - } -} - -## This used only for making the test script -sub ExpectError($$) -{ - my $FH = shift; - my $prop = shift; - - print $FH qq/Error('\\p{$prop}');\n/; - print $FH qq/Error('\\P{$prop}');\n/; -} - -## This used only for making the test script -my @GoodSeps = ( - " ", - "-", - " \t ", - "", - "", - "_", - ); -my @BadSeps = ( - "--", - "__", - " _", - "/" - ); - -## This used only for making the test script -sub RandomlyFuzzifyName($;$) -{ - my $Name = shift; - my $WantError = shift; ## if true, make an error + # Create the map for simple only if are going to output it, for otherwise + # it takes no part in anything we do. + my $to_output_simple; - my @parts; - for my $part (split /[-\s_]+/, $Name) - { - if (@parts) { - if ($WantError and rand() < 0.3) { - push @parts, $BadSeps[rand(@BadSeps)]; - $WantError = 0; - } else { - push @parts, $GoodSeps[rand(@GoodSeps)]; + # These are experimental, perhaps will need these to pass to regcomp.c to + # handle the cases where for example the Kelvin sign character folds to k, + # and in regcomp, we need to know which of the characters can have a + # non-latin1 char fold to it, so it doesn't do the optimizations it might + # otherwise. + my @latin1_singly_folded; + my @latin1_folded; + + sub setup_case_folding($) { + # Read in the case foldings in CaseFolding.txt. This handles both + # simple and full case folding. + + $to_output_simple + = property_ref('Simple_Case_Folding')->to_output_map; + + return; + } + + sub filter_case_folding_line { + # Called for each line in CaseFolding.txt + # Input lines look like: + # 0041; C; 0061; # LATIN CAPITAL LETTER A + # 00DF; F; 0073 0073; # LATIN SMALL LETTER SHARP S + # 1E9E; S; 00DF; # LATIN CAPITAL LETTER SHARP S + # + # 'C' means that folding is the same for both simple and full + # 'F' that it is only for full folding + # 'S' that it is only for simple folding + # 'T' is locale-dependent, and ignored + # 'I' is a type of 'F' used in some early releases. + # Note the trailing semi-colon, unlike many of the input files. That + # means that there will be an extra null field generated by the split + # below, which we ignore and hence is not an error. + + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my ($range, $type, $map, @remainder) = split /\s*;\s*/, $_, -1; + if (@remainder > 1 || (@remainder == 1 && $remainder[0] ne "" )) { + $file->carp_bad_line('Extra fields'); + $_ = ""; + return; + } + + if ($type eq 'T') { # Skip Turkic case folding, is locale dependent + $_ = ""; + return; + } + + # C: complete, F: full, or I: dotted uppercase I -> dotless lowercase + # I are all full foldings + if ($type eq 'C' || $type eq 'F' || $type eq 'I') { + $_ = "$range; Case_Folding; $map"; + } + else { + $_ = ""; + if ($type ne 'S') { + $file->carp_bad_line('Expecting C F I S or T in second field'); + return; } } - my $switch = int rand(4); - if ($switch == 0) { - push @parts, uc $part; - } elsif ($switch == 1) { - push @parts, lc $part; - } elsif ($switch == 2) { - push @parts, ucfirst $part; - } else { - push @parts, $part; + + # C and S are simple foldings, but simple case folding is not needed + # unless we explicitly want its map table output. + if ($to_output_simple && $type eq 'C' || $type eq 'S') { + $file->insert_adjusted_lines("$range; Simple_Case_Folding; $map"); } + + # Experimental, see comment above + if ($type ne 'S' && hex($range) >= 256) { # assumes range is 1 point + my @folded = split ' ', $map; + if (hex $folded[0] < 256 && @folded == 1) { + push @latin1_singly_folded, hex $folded[0]; + } + foreach my $folded (@folded) { + push @latin1_folded, hex $folded if hex $folded < 256; + } + } + + return; } - my $new = join('', @parts); - if ($WantError) { - if (rand() >= 0.5) { - $new .= $BadSeps[rand(@BadSeps)]; - } else { - $new = $BadSeps[rand(@BadSeps)] . $new; + sub post_fold { + # Experimental, see comment above + return; + + #local $to_trace = 1 if main::DEBUG; + @latin1_singly_folded = uniques(@latin1_singly_folded); + @latin1_folded = uniques(@latin1_folded); + trace "latin1 single folded:", map { chr $_ } sort { $a <=> $b } @latin1_singly_folded if main::DEBUG && $to_trace; + trace "latin1 folded:", map { chr $_ } sort { $a <=> $b } @latin1_folded if main::DEBUG && $to_trace; + return; + } +} # End case fold closure + +sub filter_jamo_line { + # Filter Jamo.txt lines. This routine mainly is used to populate hashes + # from this file that is used in generating the Name property for Jamo + # code points. But, it also is used to convert early versions' syntax + # into the modern form. Here are two examples: + # 1100; G # HANGUL CHOSEONG KIYEOK # Modern syntax + # U+1100; G; HANGUL CHOSEONG KIYEOK # 2.0 syntax + # + # The input is $_, the output is $_ filtered. + + my @fields = split /\s*;\s*/, $_, -1; # -1 => retain trailing null fields + + # Let the caller handle unexpected input. In earlier versions, there was + # a third field which is supposed to be a comment, but did not have a '#' + # before it. + return if @fields > (($v_version gt v3.0.0) ? 2 : 3); + + $fields[0] =~ s/^U\+//; # Also, early versions had this extraneous + # beginning. + + # Some 2.1 versions had this wrong. Causes havoc with the algorithm. + $fields[1] = 'R' if $fields[0] eq '1105'; + + # Add to structure so can generate Names from it. + my $cp = hex $fields[0]; + my $short_name = $fields[1]; + $Jamo{$cp} = $short_name; + if ($cp <= $LBase + $LCount) { + $Jamo_L{$short_name} = $cp - $LBase; + } + elsif ($cp <= $VBase + $VCount) { + $Jamo_V{$short_name} = $cp - $VBase; + } + elsif ($cp <= $TBase + $TCount) { + $Jamo_T{$short_name} = $cp - $TBase; + } + else { + Carp::my_carp_bug("Unexpected Jamo code point in $_"); + } + + + # Reassemble using just the first two fields to look like a typical + # property file line + $_ = "$fields[0]; $fields[1]"; + + return; +} + +sub register_fraction($) { + # This registers the input rational number so that it can be passed on to + # utf8_heavy.pl, both in rational and floating forms. + + my $rational = shift; + + my $float = eval $rational; + $nv_floating_to_rational{$float} = $rational; + return; +} + +sub filter_numeric_value_line { + # DNumValues contains lines of a different syntax than the typical + # property file: + # 0F33 ; -0.5 ; ; -1/2 # No TIBETAN DIGIT HALF ZERO + # + # This routine transforms $_ containing the anomalous syntax to the + # typical, by filtering out the extra columns, and convert early version + # decimal numbers to strings that look like rational numbers. + + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # Starting in 5.1, there is a rational field. Just use that, omitting the + # extra columns. Otherwise convert the decimal number in the second field + # to a rational, and omit extraneous columns. + my @fields = split /\s*;\s*/, $_, -1; + my $rational; + + if ($v_version ge v5.1.0) { + if (@fields != 4) { + $file->carp_bad_line('Not 4 semi-colon separated fields'); + $_ = ""; + return; } + $rational = $fields[3]; + $_ = join '; ', @fields[ 0, 3 ]; } - return $new; + else { + + # Here, is an older Unicode file, which has decimal numbers instead of + # rationals in it. Use the fraction to calculate the denominator and + # convert to rational. + + if (@fields != 2 && @fields != 3) { + $file->carp_bad_line('Not 2 or 3 semi-colon separated fields'); + $_ = ""; + return; + } + + my $codepoints = $fields[0]; + my $decimal = $fields[1]; + if ($decimal =~ s/\.0+$//) { + + # Anything ending with a decimal followed by nothing but 0's is an + # integer + $_ = "$codepoints; $decimal"; + $rational = $decimal; + } + else { + + my $denominator; + if ($decimal =~ /\.50*$/) { + $denominator = 2; + } + + # Here have the hardcoded repeating decimals in the fraction, and + # the denominator they imply. There were only a few denominators + # in the older Unicode versions of this file which this code + # handles, so it is easy to convert them. + + # The 4 is because of a round-off error in the Unicode 3.2 files + elsif ($decimal =~ /\.33*[34]$/ || $decimal =~ /\.6+7$/) { + $denominator = 3; + } + elsif ($decimal =~ /\.[27]50*$/) { + $denominator = 4; + } + elsif ($decimal =~ /\.[2468]0*$/) { + $denominator = 5; + } + elsif ($decimal =~ /\.16+7$/ || $decimal =~ /\.83+$/) { + $denominator = 6; + } + elsif ($decimal =~ /\.(12|37|62|87)50*$/) { + $denominator = 8; + } + if ($denominator) { + my $sign = ($decimal < 0) ? "-" : ""; + my $numerator = int((abs($decimal) * $denominator) + .5); + $rational = "$sign$numerator/$denominator"; + $_ = "$codepoints; $rational"; + } + else { + $file->carp_bad_line("Can't cope with number '$decimal'."); + $_ = ""; + return; + } + } + } + + register_fraction($rational) if $rational =~ qr{/}; + return; } -## This used only for making the test script -sub MakePropTestScript() -{ - ## this written directly -- it's huge. - force_unlink ("TestProp.pl"); - if (not open OUT, ">TestProp.pl") { - die "$0: TestProp.pl: $!\n"; +{ # Closure + my %unihan_properties; + my $iicore; + + + sub setup_unihan { + # Do any special setup for Unihan properties. + + # This property gives the wrong computed type, so override. + my $usource = property_ref('kIRG_USource'); + $usource->set_type($STRING) if defined $usource; + + # This property is to be considered binary, so change all the values + # to Y. + $iicore = property_ref('kIICore'); + if (defined $iicore) { + $iicore->add_match_table('Y') if ! defined $iicore->table('Y'); + + # We have to change the default map, because the @missing line is + # misleading, given that we are treating it as binary. + $iicore->set_default_map('N'); + $iicore->set_type($BINARY); + } + + return; } - print OUT <DATA>; - while (my ($Name, $Table) = each %ExactNameToTest) - { - GenTests(*OUT, $Name, $Table->ValidCode, $Table->InvalidCode); - ExpectError(*OUT, uc $Name) if uc $Name ne $Name; - ExpectError(*OUT, lc $Name) if lc $Name ne $Name; + sub filter_unihan_line { + # Change unihan db lines to look like the others in the db. Here is + # an input sample: + # U+341C kCangjie IEKN + + # Tabs are used instead of semi-colons to separate fields; therefore + # they may have semi-colons embedded in them. Change these to periods + # so won't screw up the rest of the code. + s/;/./g; + + # Remove lines that don't look like ones we accept. + if ($_ !~ /^ [^\t]* \t ( [^\t]* ) /x) { + $_ = ""; + return; + } + + # Extract the property, and save a reference to its object. + my $property = $1; + if (! exists $unihan_properties{$property}) { + $unihan_properties{$property} = property_ref($property); + } + + # Don't do anything unless the property is one we're handling, which + # we determine by seeing if there is an object defined for it or not + if (! defined $unihan_properties{$property}) { + $_ = ""; + return; + } + + # The iicore property is supposed to be a boolean, so convert to our + # standard boolean form. + if (defined $iicore && $unihan_properties{$property} == $iicore) { + $_ =~ s/$property.*/$property\tY/ + } + + # Convert the tab separators to our standard semi-colons, and convert + # the U+HHHH notation to the rest of the standard's HHHH + s/\t/;/g; + s/\b U \+ (?= $code_point_re )//xg; + + #local $to_trace = 1 if main::DEBUG; + trace $_ if main::DEBUG && $to_trace; + + return; } +} +sub filter_blocks_lines { + # In the Blocks.txt file, the names of the blocks don't quite match the + # names given in PropertyValueAliases.txt, so this changes them so they + # do match: Blanks and hyphens are changed into underscores. Also makes + # early release versions look like later ones + # + # $_ is transformed to the correct value. - while (my ($Name, $Table) = each %FuzzyNameToTest) - { - my $Orig = $CanonicalToOrig{$Name}; - my %Names = ( - $Name => 1, - $Orig => 1, - RandomlyFuzzifyName($Orig) => 1 - ); + my $file = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; - for my $N (keys %Names) { - GenTests(*OUT, $N, $Table->ValidCode, $Table->InvalidCode); + if ($v_version lt v3.2.0) { + if (/FEFF.*Specials/) { # Bug in old versions: line wrongly inserted + $_ = ""; + return; } - ExpectError(*OUT, RandomlyFuzzifyName($Orig, 'ERROR')); + # Old versions used a different syntax to mark the range. + $_ =~ s/;\s+/../ if $v_version lt v3.1.0; } - print OUT "Finished();\n"; - close OUT; + my @fields = split /\s*;\s*/, $_, -1; + if (@fields != 2) { + $file->carp_bad_line("Expecting exactly two fields"); + $_ = ""; + return; + } + + # Change hyphens and blanks in the block name field only + $fields[1] =~ s/[ -]/_/g; + $fields[1] =~ s/_ ( [a-z] ) /_\u$1/g; # Capitalize first letter of word + + $_ = join("; ", @fields); + return; } +{ # Closure + my $current_property; + + sub filter_old_style_proplist { + # PropList.txt has been in Unicode since version 2.0. Until 3.1, it + # was in a completely different syntax. Ken Whistler of Unicode says + # that it was something he used as an aid for his own purposes, but + # was never an official part of the standard. However, comments in + # DAge.txt indicate that non-character code points were available in + # the UCD as of 3.1. It is unclear to me (khw) how they could be + # there except through this file (but on the other hand, they first + # appeared there in 3.0.1), so maybe it was part of the UCD, and maybe + # not. But the claim is that it was published as an aid to others who + # might want some more information than was given in the official UCD + # of the time. Many of the properties in it were incorporated into + # the later PropList.txt, but some were not. This program uses this + # early file to generate property tables that are otherwise not + # accessible in the early UCD's, and most were probably not really + # official at that time, so one could argue that it should be ignored, + # and you can easily modify things to skip this. And there are bugs + # in this file in various versions. (For example, the 2.1.9 version + # removes from Alphabetic the CJK range starting at 4E00, and they + # weren't added back in until 3.1.0.) Many of this file's properties + # were later sanctioned, so this code generates tables for those + # properties that aren't otherwise in the UCD of the time but + # eventually did become official, and throws away the rest. Here is a + # list of all the ones that are thrown away: + # Bidi=* duplicates UnicodeData.txt + # Combining never made into official property; + # is \P{ccc=0} + # Composite never made into official property. + # Currency Symbol duplicates UnicodeData.txt: gc=sc + # Decimal Digit duplicates UnicodeData.txt: gc=nd + # Delimiter never made into official property; + # removed in 3.0.1 + # Format Control never made into official property; + # similar to gc=cf + # High Surrogate duplicates Blocks.txt + # Ignorable Control never made into official property; + # similar to di=y + # ISO Control duplicates UnicodeData.txt: gc=cc + # Left of Pair never made into official property; + # Line Separator duplicates UnicodeData.txt: gc=zl + # Low Surrogate duplicates Blocks.txt + # Non-break was actually listed as a property + # in 3.2, but without any code + # points. Unicode denies that this + # was ever an official property + # Non-spacing duplicate UnicodeData.txt: gc=mn + # Numeric duplicates UnicodeData.txt: gc=cc + # Paired Punctuation never made into official property; + # appears to be gc=ps + gc=pe + # Paragraph Separator duplicates UnicodeData.txt: gc=cc + # Private Use duplicates UnicodeData.txt: gc=co + # Private Use High Surrogate duplicates Blocks.txt + # Punctuation duplicates UnicodeData.txt: gc=p + # Space different definition than eventual + # one. + # Titlecase duplicates UnicodeData.txt: gc=lt + # Unassigned Code Value duplicates UnicodeData.txt: gc=cc + # Zero-width never made into offical property; + # subset of gc=cf + # Most of the properties have the same names in this file as in later + # versions, but a couple do not. + # + # This subroutine filters $_, converting it from the old style into + # the new style. Here's a sample of the old-style + # + # ******************************************* + # + # Property dump for: 0x100000A0 (Join Control) + # + # 200C..200D (2 chars) + # + # In the example, the property is "Join Control". It is kept in this + # closure between calls to the subroutine. The numbers beginning with + # 0x were internal to Ken's program that generated this file. + + # If this line contains the property name, extract it. + if (/^Property dump for: [^(]*\((.*)\)/) { + $_ = $1; + + # Convert white space to underscores. + s/ /_/g; + + # Convert the few properties that don't have the same name as + # their modern counterparts + s/Identifier_Part/ID_Continue/ + or s/Not_a_Character/NChar/; + + # If the name matches an existing property, use it. + if (defined property_ref($_)) { + trace "new property=", $_ if main::DEBUG && $to_trace; + $current_property = $_; + } + else { # Otherwise discard it + trace "rejected property=", $_ if main::DEBUG && $to_trace; + undef $current_property; + } + $_ = ""; # The property is saved for the next lines of the + # file, but this defining line is of no further use, + # so clear it so that the caller won't process it + # further. + } + elsif (! defined $current_property || $_ !~ /^$code_point_re/) { -## -## These are used only in: -## RegisterFileForName() -## WriteAllMappings() -## -my %Exact; ## will become %utf8::Exact; -my %Canonical; ## will become %utf8::Canonical; -my %CaComment; ## Comment for %Canonical entry of same key + # Here, the input line isn't a header defining a property for the + # following section, and either we aren't in such a section, or + # the line doesn't look like one that defines the code points in + # such a section. Ignore this line. + $_ = ""; + } + else { -## -## Given info about a name and a datafile that it should be associated with, -## register that assocation in %Exact and %Canonical. -sub RegisterFileForName($$$$) -{ - my $Type = shift; - my $Name = shift; - my $IsFuzzy = shift; - my $filename = shift; + # Here, we have a line defining the code points for the current + # stashed property. Anything starting with the first blank is + # extraneous. Otherwise, it should look like a normal range to + # the caller. Append the property name so that it looks just like + # a modern PropList entry. - ## - ## Now in details for the mapping. $Type eq 'Is' has the - ## Is removed, as it will be removed in utf8_heavy when this - ## data is being checked. In keeps its "In", but a second - ## sans-In record is written if it doesn't conflict with - ## anything already there. - ## - if (not $IsFuzzy) - { - if ($Type eq 'Is') { - die "oops[$Name]" if $Exact{$Name}; - $Exact{$Name} = $filename; - } else { - die "oops[$Type$Name]" if $Exact{"$Type$Name"}; - $Exact{"$Type$Name"} = $filename; - $Exact{$Name} = $filename if not $Exact{$Name}; + $_ =~ s/\s.*//; + $_ .= "; $current_property"; } + trace $_ if main::DEBUG && $to_trace; + return; } - else - { - my $CName = lc $Name; - if ($Type eq 'Is') { - die "oops[$CName]" if $Canonical{$CName}; - $Canonical{$CName} = $filename; - $CaComment{$CName} = $Name if $Name =~ tr/A-Z// >= 2; - } else { - die "oops[$Type$CName]" if $Canonical{lc "$Type$CName"}; - $Canonical{lc "$Type$CName"} = $filename; - $CaComment{lc "$Type$CName"} = "$Type$Name"; - if (not $Canonical{$CName}) { - $Canonical{$CName} = $filename; - $CaComment{$CName} = "$Type$Name"; - } - } - } -} - -## -## Writes the info accumulated in -## -## %TableInfo; -## %FuzzyNames; -## %AliasInfo; -## -## -sub WriteAllMappings() -{ - my @MAP; - - ## 'Is' *MUST* come first, so its names have precidence over 'In's - for my $Type ('Is', 'In') +} # End closure for old style proplist + +sub filter_old_style_normalization_lines { + # For early releases of Unicode, the lines were like: + # 74..2A76 ; NFKD_NO + # For later releases this became: + # 74..2A76 ; NFKD_QC; N + # Filter $_ to look like those in later releases. + # Similarly for MAYBEs + + s/ _NO \b /_QC; N/x || s/ _MAYBE \b /_QC; M/x; + + # Also, the property FC_NFKC was abbreviated to FNC + s/FNC/FC_NFKC/; + return; +} + +sub finish_Unicode() { + # This routine should be called after all the Unicode files have been read + # in. It: + # 1) Adds the mappings for code points missing from the files which have + # defaults specified for them. + # 2) At this this point all mappings are known, so it computes the type of + # each property whose type hasn't been determined yet. + # 3) Calculates all the regular expression match tables based on the + # mappings. + # 3) Calculates and adds the tables which are defined by Unicode, but + # which aren't derived by them + + # For each property, fill in any missing mappings, and calculate the re + # match tables. If a property has more than one missing mapping, the + # default is a reference to a data structure, and requires data from other + # properties to resolve. The sort is used to cause these to be processed + # last, after all the other properties have been calculated. + # (Fortunately, the missing properties so far don't depend on each other.) + foreach my $property + (sort { (defined $a->default_map && ref $a->default_map) ? 1 : -1 } + property_ref('*')) { - my %RawNameToFile; ## a per-$Type cache + # $perl has been defined, but isn't one of the Unicode properties that + # need to be finished up. + next if $property == $perl; + + # Handle the properties that have more than one possible default + if (ref $property->default_map) { + my $default_map = $property->default_map; + + # These properties have stored in the default_map: + # One or more of: + # 1) A default map which applies to all code points in a + # certain class + # 2) an expression which will evaluate to the list of code + # points in that class + # And + # 3) the default map which applies to every other missing code + # point. + # + # Go through each list. + while (my ($default, $eval) = $default_map->get_next_defaults) { + + # Get the class list, and intersect it with all the so-far + # unspecified code points yielding all the code points + # in the class that haven't been specified. + my $list = eval $eval; + if ($@) { + Carp::my_carp("Can't set some defaults for missing code points for $property because eval '$eval' failed with '$@'"); + last; + } - for my $Name (sort {length $a <=> length $b} keys %{$TableInfo{$Type}}) - { - ## Note: $Name is already canonical - my $Table = $TableInfo{$Type}->{$Name}; - my $IsFuzzy = $FuzzyNames{$Type}->{$Name}; + # Narrow down the list to just those code points we don't have + # maps for yet. + $list = $list & $property->inverse_list; - ## Need an 8.3 safe filename (which means "an 8 safe" $filename) - my $filename; - { - ## 'Is' items lose 'Is' from the basename. - $filename = $Type eq 'Is' ? - ($PVA_reverse{sc}{$Name} || $Name) : - "$Type$Name"; - - $filename =~ s/[^\w_]+/_/g; # "L&" -> "L_" - substr($filename, 8) = '' if length($filename) > 8; - - ## - ## Make sure the basename doesn't conflict with something we - ## might have already written. If we have, say, - ## InGreekExtended1 - ## InGreekExtended2 - ## they become - ## InGreekE - ## InGreek2 - ## - while (my $num = $BaseNames{lc $filename}++) - { - $num++; ## so basenames with numbers start with '2', which - ## just looks more natural. - ## Want to append $num, but if it'll make the basename longer - ## than 8 characters, pre-truncate $filename so that the result - ## is acceptable. - my $delta = length($filename) + length($num) - 8; - if ($delta > 0) { - substr($filename, -$delta) = $num; - } else { - $filename .= $num; - } + # Add mappings to the property for each code point in the list + foreach my $range ($list->ranges) { + $property->add_map($range->start, $range->end, $default); } - }; + } - ## - ## Construct a nice comment to add to the file, and build data - ## for the "./Properties" file along the way. - ## - my $Comment; - { - my $Desc = $TableDesc{$Type}->{$Name} || ""; - ## get list of names this table is reference by - my @Supported = $Name; - while (my ($Orig, $Alias) = each %{ $AliasInfo{$Type} }) + # All remaining code points have the other mapping. Set that up + # so the normal single-default mapping code will work on them + $property->set_default_map($default_map->other_default); + + # And fall through to do that + } + + # We should have enough data now to compute the type of the property. + $property->compute_type; + my $property_type = $property->type; + + next if ! $property->to_create_match_tables; + + # Here want to create match tables for this property + + # The Unicode db always (so far, and they claim into the future) have + # the default for missing entries in binary properties be 'N' (unless + # there is a '@missing' line that specifies otherwise) + if ($property_type == $BINARY && ! defined $property->default_map) { + $property->set_default_map('N'); + } + + # Add any remaining code points to the mapping, using the default for + # missing code points + if (defined (my $default_map = $property->default_map)) { + foreach my $range ($property->inverse_list->ranges) { + $property->add_map($range->start, $range->end, $default_map); + } + + # Make sure there is a match table for the default + if (! defined $property->table($default_map)) { + $property->add_match_table($default_map); + } + } + + # Have all we need to populate the match tables. + my $property_name = $property->name; + foreach my $range ($property->ranges) { + my $map = $range->value; + my $table = property_ref($property_name)->table($map); + if (! defined $table) { + + # Integral and rational property values are not necessarily + # defined in PropValueAliases, but all other ones should be, + # starting in 5.1 + if ($v_version ge v5.1.0 + && $map !~ /^ -? \d+ ( \/ \d+ )? $/x) { - if ($Orig eq $Name) { - push @Supported, $Alias; + Carp::my_carp("Table '$property_name=$map' should have been defined. Defining it now.") + } + $table = property_ref($property_name)->add_match_table($map); + } + + $table->add_range($range->start, $range->end); + } + + # And add the Is_ prefix synonyms for Perl 5.6 compatibility, in which + # all properties have this optional prefix. These do not get a + # separate entry in the pod file, because are covered by a wild-card + # entry + foreach my $alias ($property->aliases) { + my $Is_name = 'Is_' . $alias->name; + if (! defined (my $pre_existing = property_ref($Is_name))) { + $property->add_alias($Is_name, + Pod_Entry => 0, + Status => $alias->status, + Externally_Ok => 0); + } + else { + + # It seemed too much work to add in these warnings when it + # appears that Unicode has made a decision never to begin a + # property name with 'Is_', so this shouldn't happen, but just + # in case, it is a warning. + Carp::my_carp(<<END +There is already an alias named $Is_name (from " . $pre_existing . "), so not +creating this alias for $property. The generated table and pod files do not +warn users of this conflict. +END + ); + $has_Is_conflicts++; + } + } # End of loop through aliases for this property + } # End of loop through all Unicode properties. + + # Fill in the mappings that Unicode doesn't completely furnish. First the + # single letter major general categories. If Unicode were to start + # delivering the values, this would be redundant, but better that than to + # try to figure out if should skip and not get it right. Ths could happen + # if a new major category were to be introduced, and the hard-coded test + # wouldn't know about it. + # This routine depends on the standard names for the general categories + # being what it thinks they are, like 'Cn'. The major categories are the + # union of all the general category tables which have the same first + # letters. eg. L = Lu + Lt + Ll + Lo + Lm + foreach my $minor_table ($gc->tables) { + my $minor_name = $minor_table->name; + next if length $minor_name == 1; + if (length $minor_name != 2) { + Carp::my_carp_bug("Unexpected general category '$minor_name'. Skipped."); + next; + } + + my $major_name = uc(substr($minor_name, 0, 1)); + my $major_table = $gc->table($major_name); + $major_table += $minor_table; + } + + # LC is Ll, Lu, and Lt. (used to be L& or L_, but PropValueAliases.txt + # defines it as LC) + my $LC = $gc->table('LC'); + $LC->add_alias('L_', Status => $DISCOURAGED); # For backwards... + $LC->add_alias('L&', Status => $DISCOURAGED); # compatibility. + + + if ($LC->is_empty) { # Assume if not empty that Unicode has started to + # deliver the correct values in it + $LC->initialize($gc->table('Ll') + $gc->table('Lu')); + + # Lt not in release 1. + $LC += $gc->table('Lt') if defined $gc->table('Lt'); + } + $LC->add_description('[\p{Ll}\p{Lu}\p{Lt}]'); + + my $Cs = $gc->table('Cs'); + if (defined $Cs) { + $Cs->add_note('Mostly not usable in Perl.'); + $Cs->add_comment(join_lines(<<END +Surrogates are used exclusively for I/O in UTF-16, and should not appear in +Unicode text, and hence their use will generate (usually fatal) messages +END + )); + } + + + # Folding information was introduced later into Unicode data. To get + # Perl's case ignore (/i) to work at all in releases that don't have + # folding, use the best available alternative, which is lower casing. + my $fold = property_ref('Simple_Case_Folding'); + if ($fold->is_empty) { + $fold->initialize(property_ref('Simple_Lowercase_Mapping')); + $fold->add_note(join_lines(<<END +WARNING: This table uses lower case as a substitute for missing fold +information +END + )); + } + + # Multiple-character mapping was introduced later into Unicode data. If + # missing, use the single-characters maps as best available alternative + foreach my $map (qw { Uppercase_Mapping + Lowercase_Mapping + Titlecase_Mapping + Case_Folding + } ) { + my $full = property_ref($map); + if ($full->is_empty) { + my $simple = property_ref('Simple_' . $map); + $full->initialize($simple); + $full->add_comment($simple->comment) if ($simple->comment); + $full->add_note(join_lines(<<END +WARNING: This table uses simple mapping (single-character only) as a +substitute for missing multiple-character information +END + )); + } + } + return +} + +sub compile_perl() { + # Create perl-defined tables. Almost all are part of the pseudo-property + # named 'perl' internally to this program. Many of these are recommended + # in UTS#18 "Unicode Regular Expressions", and their derivations are based + # on those found there. + # Almost all of these are equivalent to some Unicode property. + # A number of these properties have equivalents restricted to the ASCII + # range, with their names prefaced by 'Posix', to signify that these match + # what the Posix standard says they should match. A couple are + # effectively this, but the name doesn't have 'Posix' in it because there + # just isn't any Posix equivalent. + + # 'Any' is all code points. As an error check, instead of just setting it + # to be that, construct it to be the union of all the major categories + my $Any = $perl->add_match_table('Any', + Description => "[\\x{0000}-\\x{$LAST_UNICODE_CODEPOINT_STRING}]", + Matches_All => 1); + + foreach my $major_table ($gc->tables) { + + # Major categories are the ones with single letter names. + next if length($major_table->name) != 1; + + $Any += $major_table; + } + + if ($Any->max != $LAST_UNICODE_CODEPOINT) { + Carp::my_carp_bug("Generated highest code point (" + . sprintf("%X", $Any->max) + . ") doesn't match expected value $LAST_UNICODE_CODEPOINT_STRING.") + } + if ($Any->range_count != 1 || $Any->min != 0) { + Carp::my_carp_bug("Generated table 'Any' doesn't match all code points.") + } + + $Any->add_alias('All'); + + # Assigned is the opposite of gc=unassigned + my $Assigned = $perl->add_match_table('Assigned', + Description => "All assigned code points", + Initialize => ~ $gc->table('Unassigned'), + ); + + # Our internal-only property should be treated as more than just a + # synonym. + $perl->add_match_table('_CombAbove') + ->set_equivalent_to(property_ref('ccc')->table('Above'), + Related => 1); + + my $ASCII = $perl->add_match_table('ASCII', Description => '[[:ASCII:]]'); + if (defined $block) { # This is equivalent to the block if have it. + my $Unicode_ASCII = $block->table('Basic_Latin'); + if (defined $Unicode_ASCII && ! $Unicode_ASCII->is_empty) { + $ASCII->set_equivalent_to($Unicode_ASCII, Related => 1); + } + } + + # Very early releases didn't have blocks, so initialize ASCII ourselves if + # necessary + if ($ASCII->is_empty) { + $ASCII->initialize([ 0..127 ]); + } + + # A number of the Perl synonyms have a restricted-range synonym whose name + # begins with Posix. This hash gets filled in with them, so that they can + # be populated in a small loop. + my %posix_equivalent; + + # Get the best available case definitions. Early Unicode versions didn't + # have Uppercase and Lowercase defined, so use the general category + # instead for them. + my $Lower = $perl->add_match_table('Lower'); + my $Unicode_Lower = property_ref('Lowercase'); + if (defined $Unicode_Lower && ! $Unicode_Lower->is_empty) { + $Lower->set_equivalent_to($Unicode_Lower->table('Y'), Related => 1); + } + else { + $Lower->set_equivalent_to($gc->table('Lowercase_Letter'), + Related => 1); + } + $posix_equivalent{'Lower'} = $Lower; + + my $Upper = $perl->add_match_table('Upper'); + my $Unicode_Upper = property_ref('Uppercase'); + if (defined $Unicode_Upper && ! $Unicode_Upper->is_empty) { + $Upper->set_equivalent_to($Unicode_Upper->table('Y'), Related => 1); + } + else { + $Upper->set_equivalent_to($gc->table('Uppercase_Letter'), + Related => 1); + } + $posix_equivalent{'Upper'} = $Upper; + + # Earliest releases didn't have title case. Initialize it to empty if not + # otherwise present + my $Title = $perl->add_match_table('Title'); + my $lt = $gc->table('Lt'); + if (defined $lt) { + $Title->set_equivalent_to($lt, Related => 1); + } + + # If this Unicode version doesn't have Cased, set up our own. From + # Unicode 5.1: Definition D120: A character C is defined to be cased if + # and only if C has the Lowercase or Uppercase property or has a + # General_Category value of Titlecase_Letter. + unless (defined property_ref('Cased')) { + my $cased = $perl->add_match_table('Cased', + Initialize => $Lower + $Upper + $Title, + Description => 'Uppercase or Lowercase or Titlecase', + ); + } + + # Similarly, set up our own Case_Ignorable property if this Unicode + # version doesn't have it. From Unicode 5.1: Definition D121: A character + # C is defined to be case-ignorable if C has the value MidLetter or the + # value MidNumLet for the Word_Break property or its General_Category is + # one of Nonspacing_Mark (Mn), Enclosing_Mark (Me), Format (Cf), + # Modifier_Letter (Lm), or Modifier_Symbol (Sk). + + # Perl has long had an internal-only alias for this property. + my $perl_case_ignorable = $perl->add_match_table('_Case_Ignorable'); + my $case_ignorable = property_ref('Case_Ignorable'); + if (defined $case_ignorable && ! $case_ignorable->is_empty) { + $perl_case_ignorable->set_equivalent_to($case_ignorable->table('Y'), + Related => 1); + } + else { + + $perl_case_ignorable->initialize($gc->table('Mn') + $gc->table('Lm')); + + # The following three properties are not in early releases + $perl_case_ignorable += $gc->table('Me') if defined $gc->table('Me'); + $perl_case_ignorable += $gc->table('Cf') if defined $gc->table('Cf'); + $perl_case_ignorable += $gc->table('Sk') if defined $gc->table('Sk'); + + # For versions 4.1 - 5.0, there is no MidNumLet property, and + # correspondingly the case-ignorable definition lacks that one. For + # 4.0, it appears that it was meant to be the same definition, but was + # inadvertently omitted from the standard's text, so add it if the + # property actually is there + my $wb = property_ref('Word_Break'); + if (defined $wb) { + my $midlet = $wb->table('MidLetter'); + $perl_case_ignorable += $midlet if defined $midlet; + my $midnumlet = $wb->table('MidNumLet'); + $perl_case_ignorable += $midnumlet if defined $midnumlet; + } + else { + + # In earlier versions of the standard, instead of the above two + # properties , just the following characters were used: + $perl_case_ignorable += 0x0027 # APOSTROPHE + + 0x00AD # SOFT HYPHEN (SHY) + + 0x2019; # RIGHT SINGLE QUOTATION MARK + } + } + + # The remaining perl defined tables are mostly based on Unicode TR 18, + # "Annex C: Compatibility Properties". All of these have two versions, + # one whose name generally begins with Posix that is posix-compliant, and + # one that matches Unicode characters beyond the Posix, ASCII range + + my $Alpha = $perl->add_match_table('Alpha', + Description => '[[:Alpha:]] extended beyond ASCII'); + + # Alphabetic was not present in early releases + my $Alphabetic = property_ref('Alphabetic'); + if (defined $Alphabetic && ! $Alphabetic->is_empty) { + $Alpha->set_equivalent_to($Alphabetic->table('Y'), Related => 1); + } + else { + + # For early releases, we don't get it exactly right. The below + # includes more than it should, which in 5.2 terms is: L + Nl + + # Other_Alphabetic. Other_Alphabetic contains many characters from + # Mn and Mc. It's better to match more than we should, than less than + # we should. + $Alpha->initialize($gc->table('Letter') + + $gc->table('Mn') + + $gc->table('Mc')); + $Alpha += $gc->table('Nl') if defined $gc->table('Nl'); + } + $posix_equivalent{'Alpha'} = $Alpha; + + my $Alnum = $perl->add_match_table('Alnum', + Description => "[[:Alnum:]] extended beyond ASCII", + Initialize => $Alpha + $gc->table('Decimal_Number'), + ); + $posix_equivalent{'Alnum'} = $Alnum; + + my $Word = $perl->add_match_table('Word', + Description => '\w, including beyond ASCII', + Initialize => $Alnum + $gc->table('Mark'), + ); + my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1 + $Word += $Pc if defined $Pc; + + # There is no [[:Word:]], so the name doesn't begin with Posix. + $perl->add_match_table('PerlWord', + Description => '\w, restricted to ASCII = [A-Za-z0-9_]', + Initialize => $Word & $ASCII, + ); + + my $Blank = $perl->add_match_table('Blank', + Description => '\h, Horizontal white space', + + # 200B is Zero Width Space which is for line + # break control, and was listed as + # Space_Separator in early releases + Initialize => $gc->table('Space_Separator') + + 0x0009 # TAB + - 0x200B, # ZWSP + ); + $Blank->add_alias('HorizSpace'); # Another name for it. + $posix_equivalent{'Blank'} = $Blank; + + my $VertSpace = $perl->add_match_table('VertSpace', + Description => '\v', + Initialize => $gc->table('Line_Separator') + + $gc->table('Paragraph_Separator') + + 0x000A # LINE FEED + + 0x000B # VERTICAL TAB + + 0x000C # FORM FEED + + 0x000D # CARRIAGE RETURN + + 0x0085, # NEL + ); + # No Posix equivalent for vertical space + + my $Space = $perl->add_match_table('Space', + Description => '\s including beyond ASCII plus vertical tab = [[:Space:]]', + Initialize => $Blank + $VertSpace, + ); + $posix_equivalent{'Space'} = $Space; + + # Perl's traditional space doesn't include Vertical Tab + my $SpacePerl = $perl->add_match_table('SpacePerl', + Description => '\s, including beyond ASCII', + Initialize => $Space - 0x000B, + ); + $perl->add_match_table('PerlSpace', + Description => '\s, restricted to ASCII', + Initialize => $SpacePerl & $ASCII, + ); + + my $Cntrl = $perl->add_match_table('Cntrl', + Description => "[[:Cntrl:]] extended beyond ASCII"); + $Cntrl->set_equivalent_to($gc->table('Cc'), Related => 1); + $posix_equivalent{'Cntrl'} = $Cntrl; + + # $controls is a temporary used to construct Graph. + my $controls = Range_List->new(Initialize => $gc->table('Unassigned') + + $gc->table('Control')); + # Cs not in release 1 + $controls += $gc->table('Surrogate') if defined $gc->table('Surrogate'); + + # Graph is ~space & ~(Cc|Cs|Cn) = ~(space + $controls) + my $Graph = $perl->add_match_table('Graph', + Description => "[[:Graph:]] extended beyond ASCII", + Initialize => ~ ($Space + $controls), + ); + $posix_equivalent{'Graph'} = $Graph; + + my $Print = $perl->add_match_table('Print', + Description => "[[:Print:]] extended beyond ASCII", + Initialize => $Space + $Graph - $gc->table('Control'), + ); + $posix_equivalent{'Print'} = $Print; + + my $Punct = $perl->add_match_table('Punct'); + $Punct->set_equivalent_to($gc->table('Punctuation'), Related => 1); + + # \p{punct} doesn't include the symbols, which posix does + $perl->add_match_table('PosixPunct', + Description => "[[:Punct:]]", + Initialize => $ASCII & ($gc->table('Punctuation') + + $gc->table('Symbol')), + ); + + my $Digit = $perl->add_match_table('Digit', + Description => '\d, extended beyond just [0-9]'); + $Digit->set_equivalent_to($gc->table('Decimal_Number'), Related => 1); + $posix_equivalent{'Digit'} = $Digit; + + # AHex was not present in early releases + my $Xdigit = $perl->add_match_table('XDigit', + Description => '[0-9A-Fa-f]'); + my $AHex = property_ref('ASCII_Hex_Digit'); + if (defined $AHex && ! $AHex->is_empty) { + $Xdigit->set_equivalent_to($AHex->table('Y'), Related => 1); + } + else { + # (Have to use hex because could be running on an non-ASCII machine, + # and we want the Unicode (ASCII) values) + $Xdigit->initialize([ 0x30..0x39, 0x41..0x46, 0x61..0x66 ]); + } + + # Now, add the ASCII-restricted tables that get uniform treatment + while (my ($name, $table) = each %posix_equivalent) { + $perl->add_match_table("Posix$name", + Description => "[[:$name:]]", + Initialize => $table & $ASCII, + ); + } + $perl->table('PosixDigit')->add_description('\d, restricted to ASCII'); + $perl->table('PosixDigit')->add_description('[0-9]'); + + + my $dt = property_ref('Decomposition_Type'); + $dt->add_match_table('Non_Canon', Full_Name => 'Non_Canonical', + Initialize => ~ ($dt->table('None') + $dt->table('Canonical')), + Perl_Extension => 1, + Note => 'Perl extension consisting of the union of all non-canonical decompositions', + ); + + # _CanonDCIJ is equivalent to Soft_Dotted, but if on a release earlier + # than SD appeared, construct it ourselves, based on the first release SD + # was in. + my $CanonDCIJ = $perl->add_match_table('_CanonDCIJ'); + my $soft_dotted = property_ref('Soft_Dotted'); + if (defined $soft_dotted && ! $soft_dotted->is_empty) { + $CanonDCIJ->set_equivalent_to($soft_dotted->table('Y'), Related => 1); + } + else { + + # This list came from 3.2 Soft_Dotted. + $CanonDCIJ->initialize([ 0x0069, + 0x006A, + 0x012F, + 0x0268, + 0x0456, + 0x0458, + 0x1E2D, + 0x1ECB, + ]); + $CanonDCIJ = $CanonDCIJ & $Assigned; + } + + # These are used in Unicode's definition of \X + my $gcb = property_ref('Grapheme_Cluster_Break'); + #my $extend = $perl->add_match_table('_X_Extend'); + my $extend = $perl->add_match_table('_GCB_Extend'); + # XXX until decide what todo my $begin = $perl->add_match_table('_X_Begin'); + if (defined $gcb) { + $extend += $gcb->table('Extend') + $gcb->table('SpacingMark') + #$begin += ~ ($gcb->table('Control') + # + $gcb->table('CR') + # + $gcb->table('LF')); + } + else { # Old definition, used on early releases. + $extend += $gc->table('Mark') + + 0x200C # ZWNJ + + 0x200D; # ZWJ + #$begin += ~ $extend; + } + + # Create a new property specially located that is a combination of the + # various Name properties: Name, Unicode_1_Name, Named Sequences, and + # Name_Alias properties. (The final duplicates elements of the first.) A + # comment for it is constructed based on the actual properties present and + # used + my $perl_charname = Property->new('Perl_Charnames', + Core_Access => '\N{...} and charnames.pm', + Default_Map => "", + Directory => '.', + File => 'Name', + Internal_Only_Warning => 1, + Perl_Extension => 1, + Range_Size_1 => 1, + Type => $STRING, + Initialize => property_ref('Unicode_1_Name'), + ); + # Name overrides Unicode_1_Name + $perl_charname->property_add_or_replace_non_nulls(property_ref('Name')); + my @composition = ('Name', 'Unicode_1_Name'); + + if (@named_sequences) { + push @composition, 'Named_Sequence'; + foreach my $sequence (@named_sequences) { + $perl_charname->add_anomalous_entry($sequence); + } + } + + my $alias_sentence = ""; + my $alias = property_ref('Name_Alias'); + if (defined $alias) { + push @composition, 'Name_Alias'; + $alias->reset_each_range; + while (my ($range) = $alias->each_range) { + next if $range->value eq ""; + if ($range->start != $range->end) { + Carp::my_carp("Expecting only one code point in the range $range. Just to keep going, using just the first code point;"); + } + $perl_charname->add_duplicate($range->start, $range->value); + } + $alias_sentence = <<END; +The Name_Alias property adds duplicate code point entries with a corrected +name. The original (less correct, but still valid) name will be physically +first. +END + } + my $comment; + if (@composition <= 2) { # Always at least 2 + $comment = join " and ", @composition; + } + else { + $comment = join ", ", @composition[0 .. scalar @composition - 2]; + $comment .= ", and $composition[-1]"; + } + + # Wait for charnames to catch up +# foreach my $entry (@more_Names, +# split "\n", <<"END" +#000A; LF +#000C; FF +#000D; CR +#0085; NEL +#200C; ZWNJ +#200D; ZWJ +#FEFF; BOM +#FEFF; BYTE ORDER MARK +#END +# ) { +# #local $to_trace = 1 if main::DEBUG; +# trace $entry if main::DEBUG && $to_trace; +# my ($code_point, $name) = split /\s*;\s*/, $entry; +# $code_point = hex $code_point; +# trace $code_point, $name if main::DEBUG && $to_trace; +# $perl_charname->add_duplicate($code_point, $name); +# } +# #$perl_charname->add_comment("This file is for charnames.pm. It is the union of the $comment properties, plus certain commonly used but unofficial names, such as 'FF' and 'ZWNJ'. Unicode_1_Name entries are used only for otherwise nameless code points.$alias_sentence"); + $perl_charname->add_comment(join_lines( <<END +This file is for charnames.pm. It is the union of the $comment properties. +Unicode_1_Name entries are used only for otherwise nameless code +points. +$alias_sentence +END + )); + + # The combining class property used by Perl's normalize.pm is not located + # in the normal mapping directory; create a copy for it. + my $ccc = property_ref('Canonical_Combining_Class'); + my $perl_ccc = Property->new('Perl_ccc', + Default_Map => $ccc->default_map, + Full_Name => 'Perl_Canonical_Combining_Class', + Internal_Only_Warning => 1, + Perl_Extension => 1, + Pod_Entry =>0, + Type => $ENUM, + Initialize => $ccc, + File => 'CombiningClass', + Directory => '.', + ); + $perl_ccc->set_to_output_map(1); + $perl_ccc->add_comment(join_lines(<<END +This mapping is for normalize.pm. It is currently identical to the Unicode +Canonical_Combining_Class property. +END + )); + + # This one match table for it is needed for calculations on output + my $default = $perl_ccc->add_match_table($ccc->default_map, + Initialize => $ccc->table($ccc->default_map), + Status => $SUPPRESSED); + + # Construct the Present_In property from the Age property. + if (-e 'DAge.txt' && defined (my $age = property_ref('Age'))) { + my $default_map = $age->default_map; + my $in = Property->new('In', + Default_Map => $default_map, + Full_Name => "Present_In", + Internal_Only_Warning => 1, + Perl_Extension => 1, + Type => $ENUM, + Initialize => $age, + ); + $in->add_comment(join_lines(<<END +This file should not be used for any purpose. The values in this file are the +same as for $age, and not for what $in really means. This is because anything +defined in a given release should have multiple values: that release and all +higher ones. But only one value per code point can be represented in a table +like this. +END + )); + + # The Age tables are named like 1.5, 2.0, 2.1, .... Sort so that the + # lowest numbered (earliest) come first, with the non-numeric one + # last. + my ($first_age, @rest_ages) = sort { ($a->name !~ /^[\d.]*$/) + ? 1 + : ($b->name !~ /^[\d.]*$/) + ? -1 + : $a->name <=> $b->name + } $age->tables; + + # The Present_In property is the cumulative age properties. The first + # one hence is identical to the first age one. + my $previous_in = $in->add_match_table($first_age->name); + $previous_in->set_equivalent_to($first_age, Related => 1); + + my $description_start = "Code point's usage introduced in version "; + $first_age->add_description($description_start . $first_age->name); + + # To construct the accumlated values, for each of the age tables + # starting with the 2nd earliest, merge the earliest with it, to get + # all those code points existing in the 2nd earliest. Repeat merging + # the new 2nd earliest with the 3rd earliest to get all those existing + # in the 3rd earliest, and so on. + foreach my $current_age (@rest_ages) { + next if $current_age->name !~ /^[\d.]*$/; # Skip the non-numeric + + my $current_in = $in->add_match_table( + $current_age->name, + Initialize => $current_age + $previous_in, + Description => $description_start + . $current_age->name + . ' or earlier', + ); + $previous_in = $current_in; + + # Add clarifying material for the corresponding age file. This is + # in part because of the confusing and contradictory information + # given in the Standard's documentation itself, as of 5.2. + $current_age->add_description( + "Code point's usage was introduced in version " + . $current_age->name); + $current_age->add_note("See also $in"); + + } + + # And finally the code points whose usages have yet to be decided are + # the same in both properties. Note that permanently unassigned code + # points actually have their usage assigned (as being permanently + # unassigned), so that these tables are not the same as gc=cn. + my $unassigned = $in->add_match_table($default_map); + my $age_default = $age->table($default_map); + $age_default->add_description(<<END +Code point's usage has not been assigned in any Unicode release thus far. +END + ); + $unassigned->set_equivalent_to($age_default, Related => 1); + } + + + # Finished creating all the perl properties. All non-internal non-string + # ones have a synonym of 'Is_' prefixed. (Internal properties begin with + # an underscore.) These do not get a separate entry in the pod file + foreach my $table ($perl->tables) { + foreach my $alias ($table->aliases) { + next if $alias->name =~ /^_/; + $table->add_alias('Is_' . $alias->name, + Pod_Entry => 0, + Status => $alias->status, + Externally_Ok => 0); + } + } + + return; +} + +sub add_perl_synonyms() { + # A number of Unicode tables have Perl synonyms that are expressed in + # the single-form, \p{name}. These are: + # All the binary property Y tables, so that \p{Name=Y} gets \p{Name} and + # \p{Is_Name} as synonyms + # \p{Script=Value} gets \p{Value}, \p{Is_Value} as synonyms + # \p{General_Category=Value} gets \p{Value}, \p{Is_Value} as synonyms + # \p{Block=Value} gets \p{In_Value} as a synonym, and, if there is no + # conflict, \p{Value} and \p{Is_Value} as well + # + # This routine generates these synonyms, warning of any unexpected + # conflicts. + + # Construct the list of tables to get synonyms for. Start with all the + # binary and the General_Category ones. + my @tables = grep { $_->type == $BINARY } property_ref('*'); + push @tables, $gc->tables; + + # If the version of Unicode includes the Script property, add its tables + if (defined property_ref('Script')) { + push @tables, property_ref('Script')->tables; + } + + # The Block tables are kept separate because they are treated differently. + # And the earliest versions of Unicode didn't include them, so add only if + # there are some. + my @blocks; + push @blocks, $block->tables if defined $block; + + # Here, have the lists of tables constructed. Process blocks last so that + # if there are name collisions with them, blocks have lowest priority. + # Should there ever be other collisions, manual intervention would be + # required. See the comments at the beginning of the program for a + # possible way to handle those semi-automatically. + foreach my $table (@tables, @blocks) { + + # For non-binary properties, the synonym is just the name of the + # table, like Greek, but for binary properties the synonym is the name + # of the property, and means the code points in its 'Y' table. + my $nominal = $table; + my $nominal_property = $nominal->property; + my $actual; + if (! $nominal->isa('Property')) { + $actual = $table; + } + else { + + # Here is a binary property. Use the 'Y' table. Verify that is + # there + my $yes = $nominal->table('Y'); + unless (defined $yes) { # Must be defined, but is permissible to + # be empty. + Carp::my_carp_bug("Undefined $nominal, 'Y'. Skipping."); + next; + } + $actual = $yes; + } + + foreach my $alias ($nominal->aliases) { + + # Attempt to create a table in the perl directory for the + # candidate table, using whatever aliases in it that don't + # conflict. Also add non-conflicting aliases for all these + # prefixed by 'Is_' (and/or 'In_' for Block property tables) + PREFIX: + foreach my $prefix ("", 'Is_', 'In_') { + + # Only Block properties can have added 'In_' aliases. + next if $prefix eq 'In_' and $nominal_property != $block; + + my $proposed_name = $prefix . $alias->name; + + # No Is_Is, In_In, nor combinations thereof + trace "$proposed_name is a no-no" if main::DEBUG && $to_trace && $proposed_name =~ /^ I [ns] _I [ns] _/x; + next if $proposed_name =~ /^ I [ns] _I [ns] _/x; + + trace "Seeing if can add alias or table: 'perl=$proposed_name' based on $nominal" if main::DEBUG && $to_trace; + + # Get a reference to any existing table in the perl + # directory with the desired name. + my $pre_existing = $perl->table($proposed_name); + + if (! defined $pre_existing) { + + # No name collision, so ok to add the perl synonym. + + my $make_pod_entry; + my $externally_ok; + my $status = $actual->status; + if ($nominal_property == $block) { + + # For block properties, the 'In' form is preferred for + # external use; the pod file contains wild cards for + # this and the 'Is' form so no entries for those; and + # we don't want people using the name without the + # 'In', so discourage that. + if ($prefix eq "") { + $make_pod_entry = 1; + $status = $status || $DISCOURAGED; + $externally_ok = 0; + } + elsif ($prefix eq 'In_') { + $make_pod_entry = 0; + $status = $status || $NORMAL; + $externally_ok = 1; + } + else { + $make_pod_entry = 0; + $status = $status || $DISCOURAGED; + $externally_ok = 0; + } + } + elsif ($prefix ne "") { + + # The 'Is' prefix is handled in the pod by a wild + # card, and we won't use it for an external name + $make_pod_entry = 0; + $status = $status || $NORMAL; + $externally_ok = 0; + } + else { + + # Here, is an empty prefix, non block. This gets its + # own pod entry and can be used for an external name. + $make_pod_entry = 1; + $status = $status || $NORMAL; + $externally_ok = 1; + } + + # Here, there isn't a perl pre-existing table with the + # name. Look through the list of equivalents of this + # table to see if one is a perl table. + foreach my $equivalent ($actual->leader->equivalents) { + next if $equivalent->property != $perl; + + # Here, have found a table for $perl. Add this alias + # to it, and are done with this prefix. + $equivalent->add_alias($proposed_name, + Pod_Entry => $make_pod_entry, + Status => $status, + Externally_Ok => $externally_ok); + trace "adding alias perl=$proposed_name to $equivalent" if main::DEBUG && $to_trace; + next PREFIX; } + + # Here, $perl doesn't already have a table that is a + # synonym for this property, add one. + my $added_table = $perl->add_match_table($proposed_name, + Pod_Entry => $make_pod_entry, + Status => $status, + Externally_Ok => $externally_ok); + # And it will be related to the actual table, since it is + # based on it. + $added_table->set_equivalent_to($actual, Related => 1); + trace "added ", $perl->table($proposed_name) if main::DEBUG && $to_trace; + next; + } # End of no pre-existing. + + # Here, there is a pre-existing table that has the proposed + # name. We could be in trouble, but not if this is just a + # synonym for another table that we have already made a child + # of the pre-existing one. + if ($pre_existing->is_equivalent_to($actual)) { + trace "$pre_existing is already equivalent to $actual; adding alias perl=$proposed_name to it" if main::DEBUG && $to_trace; + $pre_existing->add_alias($proposed_name); + next; } - my $TypeToShow = $Type eq 'Is' ? "" : $Type; - my $OrigProp; + # 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. + trace "Potential name conflict with $pre_existing having ", $pre_existing->count, " code points" if main::DEBUG && $to_trace; + if ($pre_existing->matches_identically_to($actual)) { + + # Here, they do match identically. Not a real conflict. + # Make the perl version a child of the Unicode one, except + # in the non-obvious case of where the perl name is + # already a synonym of another Unicode property. (This is + # excluded by the test for it being its own parent.) The + # reason for this exclusion is that then the two Unicode + # properties become related; and we don't really know if + # they are or not. We generate documentation based on + # relatedness, and this would be misleading. Code + # later executed in the process will cause the tables to + # be represented by a single file anyway, without making + # it look in the pod like they are necessarily related. + if ($pre_existing->parent == $pre_existing + && ($pre_existing->property == $perl + || $actual->property == $perl)) + { + trace "Setting $pre_existing equivalent to $actual since one is \$perl, and match identical sets" if main::DEBUG && $to_trace; + $pre_existing->set_equivalent_to($actual, Related => 1); + } + elsif (main::DEBUG && $to_trace) { + trace "$pre_existing is equivalent to $actual since match identical sets, but not setting them equivalent, to preserve the separateness of the perl aliases"; + trace $pre_existing->parent; + } + next PREFIX; + } - $Comment = "This file supports:\n"; - for my $N (@Supported) + # Here they didn't match identically, there is a real conflict + # between our new name and a pre-existing property. + $actual->add_conflicting($proposed_name, 'p', $pre_existing); + $pre_existing->add_conflicting($nominal->full_name, + 'p', + $actual); + + # Don't output a warning for aliases for the block + # properties (unless they start with 'In_') as it is + # expected that there will be conflicts and the block + # form loses. + if ($verbosity >= $NORMAL_VERBOSITY + && ($actual->property != $block || $prefix eq 'In_')) { - my $IsFuzzy = $FuzzyNames{$Type}->{$N}; - my $Prop = "\\p{$TypeToShow$Name}"; - $OrigProp = $Prop if not $OrigProp; #cache for aliases - if ($IsFuzzy) { - $Comment .= "\t$Prop (and fuzzy permutations)\n"; - } else { - $Comment .= "\t$Prop\n"; - } - my $MyDesc = ($N eq $Name) ? $Desc : "Alias for $OrigProp ($Desc)"; + print simple_fold(join_lines(<<END +There is already an alias named $proposed_name (from " . $pre_existing . "), +so not creating this alias for " . $actual +END + ), "", 4); + } + + # Keep track for documentation purposes. + $has_In_conflicts++ if $prefix eq 'In_'; + $has_Is_conflicts++ if $prefix eq 'Is_'; + } + } + } + + # There are some properties which have No and Yes (and N and Y) as + # property values, but aren't binary, and could possibly be confused with + # binary ones. So create caveats for them. There are tables that are + # named 'No', and tables that are named 'N', but confusion is not likely + # unless they are the same table. For example, N meaning Number or + # Neutral is not likely to cause confusion, so don't add caveats to things + # like them. + foreach my $property (grep { $_->type != $BINARY } property_ref('*')) { + my $yes = $property->table('Yes'); + if (defined $yes) { + my $y = $property->table('Y'); + if (defined $y && $yes == $y) { + foreach my $alias ($property->aliases) { + $yes->add_conflicting($alias->name); + } + } + } + my $no = $property->table('No'); + if (defined $no) { + my $n = $property->table('N'); + if (defined $n && $no == $n) { + foreach my $alias ($property->aliases) { + $no->add_conflicting($alias->name, 'P'); + } + } + } + } + + return; +} + +sub register_file_for_name($$$) { + # Given info about a table and a datafile that it should be associated + # with, register that assocation + + my $table = shift; + my $directory_ref = shift; # Array of the directory path for the file + my $file = shift; # The file name in the final directory, [-1]. + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + trace "table=$table, file=$file, directory=@$directory_ref" if main::DEBUG && $to_trace; - push @MAP, sprintf("%s %-42s %s\n", - $IsFuzzy ? '*' : ' ', $Prop, $MyDesc); + if ($table->isa('Property')) { + $table->set_file_path(@$directory_ref, $file); + push @map_properties, $table + if $directory_ref->[0] eq $map_directory; + return; + } + + # Do all of the work for all equivalent tables when called with the leader + # table, so skip if isn't the leader. + return if $table->leader != $table; + + # Join all the file path components together, using slashes. + my $full_filename = join('/', @$directory_ref, $file); + + # All go in the same subdirectory of unicore + if ($directory_ref->[0] ne $matches_directory) { + Carp::my_carp("Unexpected directory in " + . join('/', @{$directory_ref}, $file)); + } + + # For this table and all its equivalents ... + foreach my $table ($table, $table->equivalents) { + + # Associate it with its file internally. Don't include the + # $matches_directory first component + $table->set_file_path(@$directory_ref, $file); + my $sub_filename = join('/', $directory_ref->[1, -1], $file); + + my $property = $table->property; + $property = ($property == $perl) + ? "" # 'perl' is never explicitly stated + : standardize($property->name) . '='; + + my $deprecated = ($table->status eq $DEPRECATED) + ? $table->status_info + : ""; + + # And for each of the table's aliases... This inner loop eventually + # goes through all aliases in the UCD that we generate regex match + # files for + foreach my $alias ($table->aliases) { + my $name = $alias->name; + + # Generate an entry in either the loose or strict hashes, which + # will translate the property and alias names combination into the + # file where the table for them is stored. + my $standard; + if ($alias->loose_match) { + $standard = $property . standardize($alias->name); + if (exists $loose_to_file_of{$standard}) { + Carp::my_carp("Can't change file registered to $loose_to_file_of{$standard} to '$sub_filename'."); + } + else { + $loose_to_file_of{$standard} = $sub_filename; + } + } + else { + $standard = lc ($property . $name); + if (exists $stricter_to_file_of{$standard}) { + Carp::my_carp("Can't change file registered to $stricter_to_file_of{$standard} to '$sub_filename'."); } - if ($Desc) { - $Comment .= "\nMeaning: $Desc\n"; + else { + $stricter_to_file_of{$standard} = $sub_filename; + + # Tightly coupled with how utf8_heavy.pl works, for a + # floating point number that is a whole number, get rid of + # the trailing decimal point and 0's, so that utf8_heavy + # will work. Also note that this assumes that such a + # number is matched strictly; so if that were to change, + # this would be wrong. + if ((my $integer_name = $name) + =~ s/^ ( -? \d+ ) \.0+ $ /$1/x) + { + $stricter_to_file_of{$property . $integer_name} + = $sub_filename; + } } + } + # Keep a list of the deprecated properties and their filenames + if ($deprecated) { + $utf8::why_deprecated{$sub_filename} = $deprecated; } - ## - ## Okay, write the file... - ## - $Table->Write(["lib","gc_sc","$filename.pl"], $Comment); + } + } - ## and register it - $RawNameToFile{$Name} = $filename; - RegisterFileForName($Type => $Name, $IsFuzzy, $filename); + return; +} - if ($IsFuzzy) - { - my $CName = CanonicalName($Type . '_'. $Name); - $FuzzyNameToTest{$Name} = $Table if !$FuzzyNameToTest{$Name}; - $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName}; - } else { - $ExactNameToTest{$Name} = $Table; +{ # Closure + my %base_names; # Names already used for avoiding DOS 8.3 filesystem + # conflicts + my %full_dir_name_of; # Full length names of directories used. + + sub construct_filename($$$) { + # Return a file name for a table, based on the table name, but perhaps + # changed to get rid of non-portable characters in it, and to make + # sure that it is unique on a file system that allows the names before + # any period to be at most 8 characters (DOS). While we're at it + # check and complain if there are any directory conflicts. + + my $name = shift; # The name to start with + my $mutable = shift; # Boolean: can it be changed? If no, but + # yet it must be to work properly, a warning + # is given + my $directories_ref = shift; # A reference to an array containing the + # path to the file, with each element one path + # component. This is used because the same + # name can be used in different directories. + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $warn = ! defined wantarray; # If true, then if the name is + # changed, a warning is issued as well. + + if (! defined $name) { + Carp::my_carp("Undefined name in directory " + . File::Spec->join(@$directories_ref) + . ". '_' used"); + return '_'; + } + + # Make sure that no directory names conflict with each other. Look at + # each directory in the input file's path. If it is already in use, + # assume it is correct, and is merely being re-used, but if we + # truncate it to 8 characters, and find that there are two directories + # that are the same for the first 8 characters, but differ after that, + # then that is a problem. + foreach my $directory (@$directories_ref) { + my $short_dir = substr($directory, 0, 8); + if (defined $full_dir_name_of{$short_dir}) { + next if $full_dir_name_of{$short_dir} eq $directory; + Carp::my_carp("$directory conflicts with $full_dir_name_of{$short_dir}. Bad News. Continuing anyway"); } + else { + $full_dir_name_of{$short_dir} = $directory; + } + } + my $path = join '/', @$directories_ref; + $path .= '/' if $path; + + # Remove interior underscores. + (my $filename = $name) =~ s/ (?<=.) _ (?=.) //xg; + + # Change any non-word character into an underscore, and truncate to 8. + $filename =~ s/\W+/_/g; # eg., "L&" -> "L_" + substr($filename, 8) = "" if length($filename) > 8; + + # Make sure the basename doesn't conflict with something we + # might have already written. If we have, say, + # InGreekExtended1 + # InGreekExtended2 + # they become + # InGreekE + # InGreek2 + my $warned = 0; + while (my $num = $base_names{$path}{lc $filename}++) { + $num++; # so basenames with numbers start with '2', which + # just looks more natural. + + # Want to append $num, but if it'll make the basename longer + # than 8 characters, pre-truncate $filename so that the result + # is acceptable. + my $delta = length($filename) + length($num) - 8; + if ($delta > 0) { + substr($filename, -$delta) = $num; + } + else { + $filename .= $num; + } + if ($warn && ! $warned) { + $warned = 1; + Carp::my_carp("'$path$name' conflicts with another name on a filesystem with 8 significant characters (like DOS). Proceeding anyway."); + } } - ## Register aliase info - for my $Name (sort {length $a <=> length $b} keys %{$AliasInfo{$Type}}) - { - my $Alias = $AliasInfo{$Type}->{$Name}; - my $IsFuzzy = $FuzzyNames{$Type}->{$Alias}; - my $filename = $RawNameToFile{$Name}; - die "oops [$Alias]->[$Name]" if not $filename; - RegisterFileForName($Type => $Alias, $IsFuzzy, $filename); - - my $Table = $TableInfo{$Type}->{$Name}; - die "oops" if not $Table; - if ($IsFuzzy) - { - my $CName = CanonicalName($Type .'_'. $Alias); - $FuzzyNameToTest{$Alias} = $Table if !$FuzzyNameToTest{$Alias}; - $FuzzyNameToTest{$CName} = $Table if !$FuzzyNameToTest{$CName}; - } else { - $ExactNameToTest{$Alias} = $Table; + return $filename if $mutable; + + # If not changeable, must return the input name, but warn if needed to + # change it beyond shortening it. + if ($name ne $filename + && substr($name, 0, length($filename)) ne $filename) { + Carp::my_carp("'$path$name' had to be changed into '$filename'. Bad News. Proceeding anyway."); + } + return $name; + } +} + +# The pod file contains a very large table. Many of the lines in that table +# would exceed a typical output window's size, and so need to be wrapped with +# a hanging indent to make them look good. The pod language is really +# insufficient here. There is no general construct to do that in pod, so it +# is done here by beginning each such line with a space to cause the result to +# be output without formatting, and doing all the formatting here. This leads +# to the result that if the eventual display window is too narrow it won't +# look good, and if the window is too wide, no advantage is taken of that +# extra width. A further complication is that the output may be indented by +# the formatter so that there is less space than expected. What I (khw) have +# done is to assume that that indent is a particular number of spaces based on +# what it is in my Linux system; people can always resize their windows if +# necessary, but this is obviously less than desirable, but the best that can +# be expected. +my $automatic_pod_indent = 8; + +# Try to format so that uses fewest lines, but few long left column entries +# slide into the right column. An experiment on 5.1 data yielded the +# following percentages that didn't cut into the other side along with the +# associated first-column widths +# 69% = 24 +# 80% not too bad except for a few blocks +# 90% = 33; # , cuts 353/3053 lines from 37 = 12% +# 95% = 37; +my $indent_info_column = 27; # 75% of lines didn't have overlap + +my $FILLER = 3; # Length of initial boiler-plate columns in a pod line + # The 3 is because of: + # 1 for the leading space to tell the pod formatter to + # output as-is + # 1 for the flag + # 1 for the space between the flag and the main data + +sub format_pod_line ($$$;$$) { + # Take a pod line and return it, formatted properly + + my $first_column_width = shift; + my $entry = shift; # Contents of left column + my $info = shift; # Contents of right column + + my $status = shift || ""; # Any flag + + my $loose_match = shift; # Boolean. + $loose_match = 1 unless defined $loose_match; + + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + my $flags = ""; + $flags .= $STRICTER if ! $loose_match; + + $flags .= $status if $status; + + # There is a blank in the left column to cause the pod formatter to + # output the line as-is. + return sprintf " %-*s%-*s %s\n", + # The first * in the format is replaced by this, the -1 is + # to account for the leading blank. There isn't a + # hard-coded blank after this to separate the flags from + # the rest of the line, so that in the unlikely event that + # multiple flags are shown on the same line, they both + # will get displayed at the expense of that separation, + # but since they are left justified, a blank will be + # inserted in the normal case. + $FILLER - 1, + $flags, + + # The other * in the format is replaced by this number to + # cause the first main column to right fill with blanks. + # The -1 is for the guaranteed blank following it. + $first_column_width - $FILLER - 1, + $entry, + $info; +} + +my @zero_match_tables; # List of tables that have no matches in this release + +sub make_table_pod_entries($) { + # This generates the entries for the pod file for a given table. + # Also done at this time are any children tables. The output looks like: + # \p{Common} \p{Script=Common} (Short: \p{Zyyy}) (5178) + + my $input_table = shift; # Table the entry is for + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # Generate parent and all its children at the same time. + return if $input_table->parent != $input_table; + + my $property = $input_table->property; + my $type = $property->type; + my $full_name = $property->full_name; + + my $count = $input_table->count; + my $string_count = clarify_number($count); + my $status = $input_table->status; + my $status_info = $input_table->status_info; + + my $entry_for_first_table; # The entry for the first table output. + # Almost certainly, it is the parent. + + # For each related table (including itself), we will generate a pod entry + # for each name each table goes by + foreach my $table ($input_table, $input_table->children) { + + # utf8_heavy.pl cannot deal with null string property values, so don't + # output any. + next if $table->name eq ""; + + # First, gather all the info that applies to this table as a whole. + + push @zero_match_tables, $table if $count == 0; + + my $table_property = $table->property; + + # The short name has all the underscores removed, while the full name + # retains them. Later, we decide whether to output a short synonym + # for the full one, we need to compare apples to apples, so we use the + # short name's length including underscores. + my $table_property_short_name_length; + my $table_property_short_name + = $table_property->short_name(\$table_property_short_name_length); + my $table_property_full_name = $table_property->full_name; + + # Get how much savings there is in the short name over the full one + # (delta will always be <= 0) + my $table_property_short_delta = $table_property_short_name_length + - length($table_property_full_name); + my @table_description = $table->description; + my @table_note = $table->note; + + # Generate an entry for each alias in this table. + my $entry_for_first_alias; # saves the first one encountered. + foreach my $alias ($table->aliases) { + + # Skip if not to go in pod. + next unless $alias->make_pod_entry; + + # Start gathering all the components for the entry + my $name = $alias->name; + + my $entry; # Holds the left column, may include extras + my $entry_ref; # To refer to the left column's contents from + # another entry; has no extras + + # First the left column of the pod entry. Tables for the $perl + # property always use the single form. + if ($table_property == $perl) { + $entry = "\\p{$name}"; + $entry_ref = "\\p{$name}"; + } + else { # Compound form. + + # Only generate one entry for all the aliases that mean true + # or false in binary properties. Append a '*' to indicate + # some are missing. (The heading comment notes this.) + my $wild_card_mark; + if ($type == $BINARY) { + next if $name ne 'N' && $name ne 'Y'; + $wild_card_mark = '*'; + } + else { + $wild_card_mark = ""; + } + + # Colon-space is used to give a little more space to be easier + # to read; + $entry = "\\p{" + . $table_property_full_name + . ": $name$wild_card_mark}"; + + # But for the reference to this entry, which will go in the + # right column, where space is at a premium, use equals + # without a space + $entry_ref = "\\p{" . $table_property_full_name . "=$name}"; + } + + # Then the right (info) column. This is stored as components of + # an array for the moment, then joined into a string later. For + # non-internal only properties, begin the info with the entry for + # the first table we encountered (if any), as things are ordered + # so that that one is the most descriptive. This leads to the + # info column of an entry being a more descriptive version of the + # name column + my @info; + if ($name =~ /^_/) { + push @info, + '(For internal use by Perl, not necessarily stable)'; + } + elsif ($entry_for_first_alias) { + push @info, $entry_for_first_alias; + } + + # If this entry is equivalent to another, add that to the info, + # using the first such table we encountered + if ($entry_for_first_table) { + if (@info) { + push @info, "(= $entry_for_first_table)"; + } + else { + push @info, $entry_for_first_table; + } + } + + # If the name is a large integer, add an equivalent with an + # exponent for better readability + if ($name =~ /^[+-]?[\d]+$/ && $name >= 10_000) { + push @info, sprintf "(= %.1e)", $name } + + my $parenthesized = ""; + if (! $entry_for_first_alias) { + + # This is the first alias for the current table. The alias + # array is ordered so that this is the fullest, most + # descriptive alias, so it gets the fullest info. The other + # aliases are mostly merely pointers to this one, using the + # information already added above. + + # Display any status message, but only on the parent table + if ($status && ! $entry_for_first_table) { + push @info, $status_info; + } + + # Put out any descriptive info + if (@table_description || @table_note) { + push @info, join "; ", @table_description, @table_note; + } + + # Look to see if there is a shorter name we can point people + # at + my $standard_name = standardize($name); + my $short_name; + my $proposed_short = $table->short_name; + if (defined $proposed_short) { + my $standard_short = standardize($proposed_short); + + # If the short name is shorter than the standard one, or + # even it it's not, but the combination of it and its + # short property name (as in \p{prop=short} ($perl doesn't + # have this form)) saves at least two characters, then, + # cause it to be listed as a shorter synonym. + if (length $standard_short < length $standard_name + || ($table_property != $perl + && (length($standard_short) + - length($standard_name) + + $table_property_short_delta) # (<= 0) + < -2)) + { + $short_name = $proposed_short; + if ($table_property != $perl) { + $short_name = $table_property_short_name + . "=$short_name"; + } + $short_name = "\\p{$short_name}"; + } + } + + # And if this is a compound form name, see if there is a + # single form equivalent + my $single_form; + if ($table_property != $perl) { + + # Special case the binary N tables, so that will print + # \P{single}, but use the Y table values to populate + # 'single', as we haven't populated the N table. + my $test_table; + my $p; + if ($type == $BINARY + && $input_table == $property->table('No')) + { + $test_table = $property->table('Yes'); + $p = 'P'; + } + else { + $test_table = $input_table; + $p = 'p'; + } + + # Look for a single form amongst all the children. + foreach my $table ($test_table->children) { + next if $table->property != $perl; + my $proposed_name = $table->short_name; + next if ! defined $proposed_name; + + # Don't mention internal-only properties as a possible + # single form synonym + next if substr($proposed_name, 0, 1) eq '_'; + + $proposed_name = "\\$p\{$proposed_name}"; + if (! defined $single_form + || length($proposed_name) < length $single_form) + { + $single_form = $proposed_name; + + # The goal here is to find a single form; not the + # shortest possible one. We've already found a + # short name. So, stop at the first single form + # found, which is likely to be closer to the + # original. + last; + } + } + } + + # Ouput both short and single in the same parenthesized + # expression, but with only one of 'Single', 'Short' if there + # are both items. + if ($short_name || $single_form || $table->conflicting) { + $parenthesized .= '('; + $parenthesized .= "Short: $short_name" if $short_name; + if ($short_name && $single_form) { + $parenthesized .= ', '; + } + elsif ($single_form) { + $parenthesized .= 'Single: '; + } + $parenthesized .= $single_form if $single_form; + } + } + + + # Warn if this property isn't the same as one that a + # semi-casual user might expect. The other components of this + # parenthesized structure are calculated only for the first entry + # for this table, but the conflicting is deemed important enough + # to go on every entry. + my $conflicting = join " NOR ", $table->conflicting; + if ($conflicting) { + $parenthesized .= '(' if ! $parenthesized; + $parenthesized .= '; ' if $parenthesized ne '('; + $parenthesized .= "NOT $conflicting"; + } + $parenthesized .= ')' if $parenthesized; + + push @info, $parenthesized if $parenthesized; + push @info, "($string_count)" if $output_range_counts; + + # Now, we have both the entry and info so add them to the + # list of all the properties. + push @match_properties, + format_pod_line($indent_info_column, + $entry, + join( " ", @info), + $alias->status, + $alias->loose_match); + + $entry_for_first_alias = $entry_ref unless $entry_for_first_alias; + } # End of looping through the aliases for this table. + + if (! $entry_for_first_table) { + $entry_for_first_table = $entry_for_first_alias; } + } # End of looping through all the related tables + return; +} + +sub pod_alphanumeric_sort { + # Sort pod entries alphanumerically. + + # The first few character columns are filler; and get rid of all the + # trailing stuff, starting with the trailing '}', so as to sort on just + # '\p{Name=Value' + my $a = lc substr($a, $FILLER); + $a =~ s/}.*//; + my $b = lc substr($b, $FILLER); + $b =~ s/}.*//; + + # Determine if the two operands are numeric property values or not. + # A numeric property will look like \p{xyz: 3}. But the number + # can begin with an optional minus sign, and may have a + # fraction or rational component, like \p{xyz: 3/2}. If either + # isn't numeric, use alphabetic sort. + my ($a_initial, $a_number) = + ($a =~ /^\\p{ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix); + return $a cmp $b unless defined $a_number; + my ($b_initial, $b_number) = + ($b =~ /^\\p{ ( [^:=]+ [:=] \s* ) (-? \d+ (?: [.\/] \d+)? )/ix); + return $a cmp $b unless defined $b_number; + + # Here they are both numeric, but use alphabetic sort if the + # initial parts don't match + return $a cmp $b if $a_initial ne $b_initial; + + # Convert rationals to floating for the comparison. + $a_number = eval $a_number if $a_number =~ qr{/}; + $b_number = eval $b_number if $b_number =~ qr{/}; + + return $a_number <=> $b_number; +} + +sub make_pod () { + # Create the .pod file. This generates the various subsections and then + # combines them in one big HERE document. + + return unless defined $pod_directory; + print "Making pod file\n" if $verbosity >= $PROGRESS; + + my $exception_message = + '(Any exceptions are individually noted beginning with the word NOT.)'; + my @block_warning; + if (-e 'Blocks.txt') { + + # Add the line: '\p{In_*} \p{Block: *}', with the warning message + # if the global $has_In_conflicts indicates we have them. + push @match_properties, format_pod_line($indent_info_column, + '\p{In_*}', + '\p{Block: *}' + . (($has_In_conflicts) + ? " $exception_message" + : "")); + @block_warning = << "END"; + +Matches in the Block property have shortcuts that begin with 'In_'. For +example, \\p{Block=Latin1} can be written as \\p{In_Latin1}. For backward +compatibility, if there is no conflict with another shortcut, these may also +be written as \\p{Latin1} or \\p{Is_Latin1}. But, N.B., there are numerous +such conflicting shortcuts. Use of these forms for Block is discouraged, and +are flagged as such, not only because of the potential confusion as to what is +meant, but also because a later release of Unicode may preempt the shortcut, +and your program would no longer be correct. Use the 'In_' form instead to +avoid this, or even more clearly, use the compound form, e.g., +\\p{blk:latin1}. See L<perlunicode/"Blocks"> for more information about this. +END + } + my $text = "If an entry has flag(s) at its beginning, like '$DEPRECATED', the 'Is_' form has the same flag(s)"; + $text = "$exception_message $text" if $has_Is_conflicts; + + # And the 'Is_ line'; + push @match_properties, format_pod_line($indent_info_column, + '\p{Is_*}', + "\\p{*} $text"); + + # Sort the properties array for output. It is sorted alphabetically + # except numerically for numeric properties, and only output unique lines. + @match_properties = sort pod_alphanumeric_sort uniques @match_properties; + + my $formatted_properties = simple_fold(\@match_properties, + "", + # indent succeeding lines by two extra + # which looks better + $indent_info_column + 2, + + # shorten the line length by how much + # the formatter indents, so the folded + # line will fit in the space + # presumably available + $automatic_pod_indent); + # Add column headings, indented to be a little more centered, but not + # exactly + $formatted_properties = format_pod_line($indent_info_column, + ' NAME', + ' INFO') + . "\n" + . $formatted_properties; + + # Generate pod documentation lines for the tables that match nothing + my $zero_matches; + if (@zero_match_tables) { + @zero_match_tables = uniques(@zero_match_tables); + $zero_matches = join "\n\n", + map { $_ = '=item \p{' . $_->complete_name . "}" } + sort { $a->complete_name cmp $b->complete_name } + uniques(@zero_match_tables); + + $zero_matches = <<END; + +=head2 Legal \\p{} and \\P{} constructs that match no characters + +Unicode has some property-value pairs that currently don't match anything. +This happens generally either because they are obsolete, or for symmetry with +other forms, but no language has yet been encoded that uses them. In this +version of Unicode, the following match zero code points: + +=over 4 + +$zero_matches + +=back + +END } - ## - ## Write out the property list - ## - { - my @OUT = ( - "##\n", - "## This file created by $0\n", - "## List of built-in \\p{...}/\\P{...} properties.\n", - "##\n", - "## '*' means name may be 'fuzzy'\n", - "##\n\n", - sort { substr($a,2) cmp substr($b, 2) } @MAP, - ); - WriteIfChanged('Properties', @OUT); - } - - ## Write Exact.pl + # Generate list of properties that we don't accept, grouped by the reasons + # why. This is so only put out the 'why' once, and then list all the + # properties that have that reason under it. + + my %why_list; # The keys are the reasons; the values are lists of + # properties that have the key as their reason + + # For each property, add it to the list that are suppressed for its reason + # The sort will cause the alphabetically first properties to be added to + # each list first, so each list will be sorted. + foreach my $property (sort keys %why_suppressed) { + push @{$why_list{$why_suppressed{$property}}}, $property; + } + + # For each reason (sorted by the first property that has that reason)... + my @bad_re_properties; + foreach my $why (sort { $why_list{$a}->[0] cmp $why_list{$b}->[0] } + keys %why_list) { - my @OUT = ( - $HEADER, - "##\n", - "## Data in this file used by ../utf8_heavy.pl\n", - "##\n\n", - "## Mapping from name to filename in ./lib/gc_sc\n", - "%utf8::Exact = (\n", - ); - - $Exact{InGreek} = 'InGreekA'; # this is evil kludge - for my $Name (sort keys %Exact) + # Add to the output, all the properties that have that reason. Start + # with an empty line. + push @bad_re_properties, "\n\n"; + + my $has_item = 0; # Flag if actually output anything. + foreach my $name (@{$why_list{$why}}) { + + # Split compound names into $property and $table components + my $property = $name; + my $table; + if ($property =~ / (.*) = (.*) /x) { + $property = $1; + $table = $2; + } + + # This release of Unicode may not have a property that is + # suppressed, so don't reference a non-existent one. + $property = property_ref($property); + next if ! defined $property; + + # And since this list is only for match tables, don't list the + # ones that don't have match tables. + next if ! $property->to_create_match_tables; + + # Find any abbreviation, and turn it into a compound name if this + # is a property=value pair. + my $short_name = $property->name; + $short_name .= '=' . $property->table($table)->name if $table; + + # And add the property as an item for the reason. + push @bad_re_properties, "\n=item I<$name> ($short_name)\n"; + $has_item = 1; + } + + # And add the reason under the list of properties, if such a list + # actually got generated. Note that the header got added + # unconditionally before. But pod ignores extra blank lines, so no + # harm. + push @bad_re_properties, "\n$why\n" if $has_item; + + } # End of looping through each reason. + + # Generate a list of the properties whose map table we output, from the + # global @map_properties. + my @map_tables_actually_output; + my $info_indent = 20; # Left column is narrower than \p{} table. + foreach my $property (@map_properties) { + + # Get the path to the file; don't output any not in the standard + # directory. + my @path = $property->file_path; + next if $path[0] ne $map_directory; + shift @path; # Remove the standard name + + my $file = join '/', @path; # In case is in sub directory + my $info = $property->full_name; + my $short_name = $property->name; + if ($info ne $short_name) { + $info .= " ($short_name)"; + } + foreach my $more_info ($property->description, + $property->note, + $property->status_info) { - my $File = $Exact{$Name}; - $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name "; - my $Text = sprintf("%-15s => %s,\n", $Name, qq/'$File'/); - push @OUT, Text::Tabs::unexpand($Text); + next unless $more_info; + $info =~ s/\.\Z//; + $info .= ". $more_info"; } - push @OUT, ");\n1;\n"; + push @map_tables_actually_output, format_pod_line($info_indent, + $file, + $info, + $property->status); + } - WriteIfChanged('Exact.pl', @OUT); + # Sort alphabetically, and fold for output + @map_tables_actually_output = sort + pod_alphanumeric_sort @map_tables_actually_output; + @map_tables_actually_output + = simple_fold(\@map_tables_actually_output, + ' ', + $info_indent, + $automatic_pod_indent); + + # Generate a list of the formats that can appear in the map tables. + my @map_table_formats; + foreach my $format (sort keys %map_table_formats) { + push @map_table_formats, " $format $map_table_formats{$format}\n"; } - ## Write Canonical.pl - { - my @OUT = ( - $HEADER, - "##\n", - "## Data in this file used by ../utf8_heavy.pl\n", - "##\n\n", - "## Mapping from lc(canonical name) to filename in ./lib\n", - "%utf8::Canonical = (\n", - ); - my $Trail = ""; ## used just to keep the spacing pretty - for my $Name (sort keys %Canonical) + # Everything is ready to assemble. + my @OUT = << "END"; +=begin comment + +$HEADER + +To change this file, edit $0 instead. + +=end comment + +=head1 NAME + +$pod_file - Complete index of Unicode Version $string_version properties + +=head1 DESCRIPTION + +There are many properties in Unicode, and Perl provides access to almost all of +them, as well as some additional extensions and short-cut synonyms. + +And just about all of the few that aren't accessible through the Perl +core are accessible through the modules: Unicode::Normalize and +Unicode::UCD, and for Unihan properties, via the CPAN module Unicode::Unihan. + +This document merely lists all available properties and does not attempt to +explain what each property really means. There is a brief description of each +Perl extension. There is some detail about Blocks, Scripts, General_Category, +and Bidi_Class in L<perlunicode>, but to find out about the intricacies of the +Unicode properties, refer to the Unicode standard. A good starting place is +L<$unicode_reference_url>. More information on the Perl extensions is in +L<perlrecharclass>. + +Note that you can define your own properties; see +L<perlunicode/"User-Defined Character Properties">. + +=head1 Properties accessible through \\p{} and \\P{} + +The Perl regular expression \\p{} and \\P{} constructs give access to most of +the Unicode character properties. The table below shows all these constructs, +both single and compound forms. + +B<Compound forms> consist of two components, separated by an equals sign or a +colon. The first component is the property name, and the second component is +the particular value of the property to match against, for example, +'\\p{Script: Greek}' or '\\p{Script=Greek}' both mean to match characters +whose Script property is Greek. + +B<Single forms>, like '\\p{Greek}', are mostly Perl-defined shortcuts for +their equivalent compound forms. The table shows these equivalences. (In our +example, '\\p{Greek}' is a just a shortcut for '\\p{Script=Greek}'.) +There are also a few Perl-defined single forms that are not shortcuts for a +compound form. One such is \\p{Word}. These are also listed in the table. + +In parsing these constructs, Perl always ignores Upper/lower case differences +everywhere within the {braces}. Thus '\\p{Greek}' means the same thing as +'\\p{greek}'. But note that changing the case of the 'p' or 'P' before the +left brace completely changes the meaning of the construct, from "match" (for +'\\p{}') to "doesn't match" (for '\\P{}'). Casing in this document is for +improved legibility. + +Also, white space, hyphens, and underscores are also normally ignored +everywhere between the {braces}, and hence can be freely added or removed +even if the C</x> modifier hasn't been specified on the regular expression. +But $a_bold_stricter at the beginning of an entry in the table below +means that tighter (stricter) rules are used for that entry: + +=over 4 + +=item Single form (\\p{name}) tighter rules: + +White space, hyphens, and underscores ARE significant +except for: + +=over 4 + +=item * white space adjacent to a non-word character + +=item * underscores separating digits in numbers + +=back + +That means, for example, that you can freely add or remove white space +adjacent to (but within) the braces without affecting the meaning. + +=item Compound form (\\p{name=value} or \\p{name:value}) tighter rules: + +The tighter rules given above for the single form apply to everything to the +right of the colon or equals; the looser rules still apply to everything to +the left. + +That means, for example, that you can freely add or remove white space +adjacent to (but within) the braces and the colon or equal sign. + +=back + +Some properties are considered obsolete, but still available. There are +several varieties of obsolesence: + +=over 4 + +=item Obsolete + +Properties marked with $a_bold_obsolete in the table are considered +obsolete. At the time of this writing (Unicode version 5.2) there is no +information in the Unicode standard about the implications of a property being +obsolete. + +=item Stabilized + +Obsolete properties may be stabilized. This means that they are not actively +maintained by Unicode, and will not be extended as new characters are added to +the standard. Such properties are marked with $a_bold_stabilized in the +table. At the time of this writing (Unicode version 5.2) there is no further +information in the Unicode standard about the implications of a property being +stabilized. + +=item Deprecated + +Obsolete properties may be deprecated. This means that their use is strongly +discouraged, so much so that a warning will be issued if used, unless the +regular expression is in the scope of a C<S<no warnings 'deprecated'>> +statement. $A_bold_deprecated flags each such entry in the table, and +the entry there for the longest, most descriptive version of the property will +give the reason it is deprecated, and perhaps advice. Perl may issue such a +warning, even for properties that aren't officially deprecated by Unicode, +when there used to be characters or code points that were matched by them, but +no longer. This is to warn you that your program may not work like it did on +earlier Unicode releases. + +A deprecated property may be made unavailable in a future Perl version, so it +is best to move away from them. + +=back + +Some Perl extensions are present for backwards compatibility and are +discouraged from being used, but not obsolete. $A_bold_discouraged +flags each such entry in the table. + +@block_warning + +The table below has two columns. The left column contains the \\p{} +constructs to look up, possibly preceeded by the flags mentioned above; and +the right column contains information about them, like a description, or +synonyms. It shows both the single and compound forms for each property that +has them. If the left column is a short name for a property, the right column +will give its longer, more descriptive name; and if the left column is the +longest name, the right column will show any equivalent shortest name, in both +single and compound forms if applicable. + +The right column will also caution you if a property means something different +than what might normally be expected. + +Numbers in (parentheses) indicate the total number of code points matched by +the property. For emphasis, those properties that match no code points at all +are listed as well in a separate section following the table. + +There is no description given for most non-Perl defined properties (See +$unicode_reference_url for that). + +For compactness, 'B<*>' is used as a wildcard instead of showing all possible +combinations. For example, entries like: + + \\p{Gc: *} \\p{General_Category: *} + +mean that 'Gc' is a synonym for 'General_Category', and anything that is valid +for the latter is also valid for the former. Similarly, + + \\p{Is_*} \\p{*} + +means that if and only if, for example, \\p{Foo} exists, then \\p{Is_Foo} and +\\p{IsFoo} are also valid and all mean the same thing. And similarly, +\\p{Foo=Bar} means the same as \\p{Is_Foo=Bar} and \\p{IsFoo=Bar}. '*' here +is restricted to something not beginning with an underscore. + +Also, in binary properties, 'Yes', 'T', and 'True' are all synonyms for 'Y'. +And 'No', 'F', and 'False' are all synonyms for 'N'. The table shows 'Y*' and +'N*' to indicate this, and doesn't have separate entries for the other +possibilities. Note that not all properties which have values 'Yes' and 'No' +are binary, and they have all their values spelled out without using this wild +card, and a C<NOT> clause in their description that highlights their not being +binary. These also require the compound form to match them, whereas true +binary properties have both single and compound forms available. + +Note that all non-essential underscores are removed in the display of the +short names below. + +B<Summary legend:> + +=over 4 + +=item B<*> is a wild-card + +=item B<(\\d+)> in the info column gives the number of code points matched by +this property. + +=item B<$DEPRECATED> means this is deprecated. + +=item B<$OBSOLETE> means this is obsolete. + +=item B<$STABILIZED> means this is stabilized. + +=item B<$STRICTER> means tighter (stricter) name matching applies. + +=item B<$DISCOURAGED> means use of this form is discouraged. + +=back + +$formatted_properties + +$zero_matches + +=head1 Properties not accessible through \\p{} and \\P{} + +A few properties are accessible in Perl via various function calls only. +These are: + Lowercase_Mapping lc() and lcfirst() + Titlecase_Mapping ucfirst() + Uppercase_Mapping uc() + +Case_Folding is accessible through the /i modifier in regular expressions. + +The Name property is accessible through the \\N{} interpolation in +double-quoted strings and regular expressions, but both usages require a C<use +charnames;> to be specified, which also contains related functions viacode() +and vianame(). + +=head1 Unicode regular expression properties that are NOT accepted by Perl + +Perl will generate an error for a few character properties in Unicode when +used in a regular expression. The non-Unihan ones are listed below, with the +reasons they are not accepted, perhaps with work-arounds. The short names for +the properties are listed enclosed in (parentheses). + +=over 4 + +@bad_re_properties + +=back + +An installation can choose to allow any of these to be matched by changing the +controlling lists contained in the program C<\$Config{privlib}>/F<unicore/$0> +and then re-running F<$0>. (C<\%Config> is available from the Config module). + +=head1 Files in the I<To> directory (for serious hackers only) + +All Unicode properties are really mappings (in the mathematical sense) from +code points to their respective values. As part of its build process, +Perl constructs tables containing these mappings for all properties that it +deals with. But only a few of these are written out into files. +Those written out are in the directory C<\$Config{privlib}>/F<unicore/To/> +(%Config is available from the Config module). + +Those ones written are ones needed by Perl internally during execution, or for +which there is some demand, and those for which there is no access through the +Perl core. Generally, properties that can be used in regular expression +matching do not have their map tables written, like Script. Nor are the +simplistic properties that have a better, more complete version, such as +Simple_Uppercase_Mapping (Uppercase_Mapping is written instead). + +None of the properties in the I<To> directory are currently directly +accessible through the Perl core, although some may be accessed indirectly. +For example, the uc() function implements the Uppercase_Mapping property and +uses the F<Upper.pl> file found in this directory. + +The available files with their properties (short names in parentheses), +and any flags or comments about them, are: + +@map_tables_actually_output + +An installation can choose to change which files are generated by changing the +controlling lists contained in the program C<\$Config{privlib}>/F<unicore/$0> +and then re-running F<$0>. + +Each of these files defines two hash entries to help reading programs decipher +it. One of them looks like this: + + \$utf8::SwashInfo{'ToNAME'}{'format'} = 's'; + +where 'NAME' is a name to indicate the property. For backwards compatibility, +this is not necessarily the property's official Unicode name. (The 'To' is +also for backwards compatibility.) The hash entry gives the format of the +mapping fields of the table, currently one of the following: + + @map_table_formats + +This format applies only to the entries in the main body of the table. +Entries defined in hashes or ones that are missing from the list can have a +different format. + +The value that the missing entries have is given by the other SwashInfo hash +entry line; it looks like this: + + \$utf8::SwashInfo{'ToNAME'}{'missing'} = 'NaN'; + +This example line says that any Unicode code points not explicitly listed in +the file have the value 'NaN' under the property indicated by NAME. If the +value is the special string C<< <code point> >>, it means that the value for +any missing code point is the code point itself. This happens, for example, +in the file for Uppercase_Mapping (To/Upper.pl), in which code points like the +character 'A', are missing because the uppercase of 'A' is itself. + +=head1 SEE ALSO + +L<$unicode_reference_url> + +L<perlrecharclass> + +L<perlunicode> + +END + + # And write it. + main::write([ $pod_directory, "$pod_file.pod" ], @OUT); + return; +} + +sub make_Heavy () { + # Create and write Heavy.pl, which passes info about the tables to + # utf8_heavy.pl + + my @heavy = <<END; +$HEADER +$INTERNAL_ONLY + +# This file is for the use of utf8_heavy.pl + +# Maps property names in loose standard form to its standard name +\%utf8::loose_property_name_of = ( +END + + push @heavy, simple_dumper (\%loose_property_name_of, ' ' x 4); + push @heavy, <<END; +); + +# Maps property, table to file for those using stricter matching +\%utf8::stricter_to_file_of = ( +END + push @heavy, simple_dumper (\%stricter_to_file_of, ' ' x 4); + push @heavy, <<END; +); + +# Maps property, table to file for those using loose matching +\%utf8::loose_to_file_of = ( +END + push @heavy, simple_dumper (\%loose_to_file_of, ' ' x 4); + push @heavy, <<END; +); + +# Maps floating point to fractional form +\%utf8::nv_floating_to_rational = ( +END + push @heavy, simple_dumper (\%nv_floating_to_rational, ' ' x 4); + push @heavy, <<END; +); + +# If a floating point number doesn't have enough digits in it to get this +# close to a fraction, it isn't considered to be that fraction even if all the +# digits it does have match. +\$utf8::max_floating_slop = $MAX_FLOATING_SLOP; + +# Deprecated tables to generate a warning for. The key is the file containing +# the table, so as to avoid duplication, as many property names can map to the +# file, but we only need one entry for all of them. +\%utf8::why_deprecated = ( +END + + push @heavy, simple_dumper (\%utf8::why_deprecated, ' ' x 4); + push @heavy, <<END; +); + +1; +END + + main::write("Heavy.pl", @heavy); + return; +} + +sub write_all_tables() { + # Write out all the tables generated by this program to files, as well as + # the supporting data structures, pod file, and .t file. + + my @writables; # List of tables that actually get written + my %match_tables_to_write; # Used to collapse identical match tables + # into one file. Each key is a hash function + # result to partition tables into buckets. + # Each value is an array of the tables that + # fit in the bucket. + + # For each property ... + # (sort so that if there is an immutable file name, it has precedence, so + # some other property can't come in and take over its file name. If b's + # file name is defined, will return 1, meaning to take it first; don't + # care if both defined, as they had better be different anyway) + PROPERTY: + foreach my $property (sort { defined $b->file } property_ref('*')) { + my $type = $property->type; + + # And for each table for that property, starting with the mapping + # table for it ... + TABLE: + foreach my $table($property, + + # and all the match tables for it (if any), sorted so + # the ones with the shortest associated file name come + # first. The length sorting prevents problems of a + # longer file taking a name that might have to be used + # by a shorter one. The alphabetic sorting prevents + # differences between releases + sort { my $ext_a = $a->external_name; + return 1 if ! defined $ext_a; + my $ext_b = $b->external_name; + return -1 if ! defined $ext_b; + my $cmp = length $ext_a <=> length $ext_b; + + # Return result if lengths not equal + return $cmp if $cmp; + + # Alphabetic if lengths equal + return $ext_a cmp $ext_b + } $property->tables + ) { - my $File = $Canonical{$Name}; - if ($CaComment{$Name}) { - push @OUT, "\n" if not $Trail; - push @OUT, " # $CaComment{$Name}\n"; - $Trail = "\n"; - } else { - $Trail = ""; + + # Here we have a table associated with a property. It could be + # the map table (done first for each property), or one of the + # other tables. Determine which type. + my $is_property = $table->isa('Property'); + + my $name = $table->name; + my $complete_name = $table->complete_name; + + # See if should suppress the table if is empty, but warn if it + # contains something. + my $suppress_if_empty_warn_if_not = grep { $complete_name eq $_ } + keys %why_suppress_if_empty_warn_if_not; + + # Calculate if this table should have any code points associated + # with it or not. + my $expected_empty = + + # $perl should be empty, as well as properties that we just + # don't do anything with + ($is_property + && ($table == $perl + || grep { $complete_name eq $_ } + @unimplemented_properties + ) + ) + + # Match tables in properties we skipped populating should be + # empty + || (! $is_property && ! $property->to_create_match_tables) + + # Tables and properties that are expected to have no code + # points should be empty + || $suppress_if_empty_warn_if_not + ; + + # Set a boolean if this table is the complement of an empty binary + # table + my $is_complement_of_empty_binary = + $type == $BINARY && + (($table == $property->table('Y') + && $property->table('N')->is_empty) + || ($table == $property->table('N') + && $property->table('Y')->is_empty)); + + + # Some tables should match everything + my $expected_full = + ($is_property) + ? # All these types of map tables will be full because + # they will have been populated with defaults + ($type == $ENUM || $type == $BINARY) + + : # A match table should match everything if its method + # shows it should + ($table->matches_all + + # The complement of an empty binary table will match + # everything + || $is_complement_of_empty_binary + ) + ; + + if ($table->is_empty) { + + + if ($suppress_if_empty_warn_if_not) { + $table->set_status($SUPPRESSED, + $why_suppress_if_empty_warn_if_not{$complete_name}); + } + + # Suppress expected empty tables. + next TABLE if $expected_empty; + + # And setup to later output a warning for those that aren't + # known to be allowed to be empty. Don't do the warning if + # this table is a child of another one to avoid duplicating + # the warning that should come from the parent one. + if (($table == $property || $table->parent == $table) + && $table->status ne $SUPPRESSED + && ! grep { $complete_name =~ /^$_$/ } + @tables_that_may_be_empty) + { + push @unhandled_properties, "$table"; + } + } + elsif ($expected_empty) { + my $because = ""; + if ($suppress_if_empty_warn_if_not) { + $because = " because $why_suppress_if_empty_warn_if_not{$complete_name}"; + } + + Carp::my_carp("Not expecting property $table$because. Generating file for it anyway."); + } + + my $count = $table->count; + if ($expected_full) { + if ($count != $MAX_UNICODE_CODEPOINTS) { + Carp::my_carp("$table matches only " + . clarify_number($count) + . " Unicode code points but should match " + . clarify_number($MAX_UNICODE_CODEPOINTS) + . " (off by " + . clarify_number(abs($MAX_UNICODE_CODEPOINTS - $count)) + . "). Proceeding anyway."); + } + + # Here is expected to be full. If it is because it is the + # complement of an (empty) binary table that is to be + # suppressed, then suppress this one as well. + if ($is_complement_of_empty_binary) { + my $opposing_name = ($name eq 'Y') ? 'N' : 'Y'; + my $opposing = $property->table($opposing_name); + my $opposing_status = $opposing->status; + if ($opposing_status) { + $table->set_status($opposing_status, + $opposing->status_info); + } + } + } + elsif ($count == $MAX_UNICODE_CODEPOINTS) { + if ($table == $property || $table->leader == $table) { + Carp::my_carp("$table unexpectedly matches all Unicode code points. Proceeding anyway."); + } + } + + if ($table->status eq $SUPPRESSED) { + if (! $is_property) { + my @children = $table->children; + foreach my $child (@children) { + if ($child->status ne $SUPPRESSED) { + Carp::my_carp_bug("'$table' is suppressed and has a child '$child' which isn't"); + } + } + } + next TABLE; + + } + if (! $is_property) { + + # Several things need to be done just once for each related + # group of match tables. Do them on the parent. + if ($table->parent == $table) { + + # Add an entry in the pod file for the table; it also does + # the children. + make_table_pod_entries($table) if defined $pod_directory; + + # See if the 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 + # in buckets, so that it is quite likely that if two + # tables are in the same bucket they will be identical, so + # don't have to compare tables frequently. The tables + # have to have the same status to share a file, so add + # this to the bucket hash. (The reason for this latter is + # that Heavy.pl associates a status with a file.) + my $hash = $table->hash . ';' . $table->status; + + # Look at each table that is in the same bucket as this + # one would be. + foreach my $comparison (@{$match_tables_to_write{$hash}}) + { + if ($table->matches_identically_to($comparison)) { + $table->set_equivalent_to($comparison, + Related => 0); + next TABLE; + } + } + + # Here, not equivalent, add this table to the bucket. + push @{$match_tables_to_write{$hash}}, $table; + } } - $Name = $Name =~ m/\W/ ? qq/'$Name'/ : " $Name "; - my $Text = sprintf(" %-41s => %s,\n$Trail", $Name, qq/'$File'/); - push @OUT, Text::Tabs::unexpand($Text); + else { + + # Here is the property itself. + # Don't write out or make references to the $perl property + next if $table == $perl; + + if ($type != $STRING) { + + # There is a mapping stored of the various synonyms to the + # standardized name of the property for utf8_heavy.pl. + # Also, the pod file contains entries of the form: + # \p{alias: *} \p{full: *} + # rather than show every possible combination of things. + + my @property_aliases = $property->aliases; + + # The full name of this property is stored by convention + # first in the alias array + my $full_property_name = + '\p{' . $property_aliases[0]->name . ': *}'; + my $standard_property_name = standardize($table->name); + + # For each synonym ... + for my $i (0 .. @property_aliases - 1) { + my $alias = $property_aliases[$i]; + my $alias_name = $alias->name; + my $alias_standard = standardize($alias_name); + + # Set the mapping for utf8_heavy of the alias to the + # property + if (exists ($loose_property_name_of{$alias_standard})) + { + Carp::my_carp("There already is a property with the same standard name as $alias_name: $loose_property_name_of{$alias_standard}. Old name is retained"); + } + else { + $loose_property_name_of{$alias_standard} + = $standard_property_name; + } + + # Now for the pod entry for this alias. Skip if not + # outputting a pod; skip the first one, which is the + # full name so won't have an entry like: '\p{full: *} + # \p{full: *}', and skip if don't want an entry for + # this one. + next if $i == 0 + || ! defined $pod_directory + || ! $alias->make_pod_entry; + + push @match_properties, + format_pod_line($indent_info_column, + '\p{' . $alias->name . ': *}', + $full_property_name, + $alias->status); + } + } # End of non-string-like property code + + + # Don't output a mapping file if not desired. + next if ! $property->to_output_map; + } + + # Here, we know we want to write out the table, but don't do it + # yet because there may be other tables that come along and will + # want to share the file, and the file's comments will change to + # mention them. So save for later. + push @writables, $table; + + } # End of looping through the property and all its tables. + } # End of looping through all properties. + + # Now have all the tables that will have files written for them. Do it. + foreach my $table (@writables) { + my @directory; + my $filename; + my $property = $table->property; + my $is_property = ($table == $property); + if (! $is_property) { + + # Match tables for the property go in lib/$subdirectory, which is + # the property's name. Don't use the standard file name for this, + # as may get an unfamiliar alias + @directory = ($matches_directory, $property->external_name); + } + else { + + @directory = $table->directory; + $filename = $table->file; } - push @OUT, ");\n1\n"; - WriteIfChanged('Canonical.pl', @OUT); + + # Use specified filename if avaliable, or default to property's + # shortest name. We need an 8.3 safe filename (which means "an 8 + # safe" filename, since after the dot is only 'pl', which is < 3) + # The 2nd parameter is if the filename shouldn't be changed, and + # it shouldn't iff there is a hard-coded name for this table. + $filename = construct_filename( + $filename || $table->external_name, + ! $filename, # mutable if no filename + \@directory); + + register_file_for_name($table, \@directory, $filename); + + # Only need to write one file when shared by more than one + # property + next if ! $is_property && $table->leader != $table; + + # Construct a nice comment to add to the file + $table->set_final_comment; + + $table->write; } - MakePropTestScript() if $MakeTestScript; + + # Write out the pod file + make_pod; + + # And Heavy.pl + make_Heavy; + + make_property_test_script() if $make_test_script; + return; } +my @white_space_separators = ( # This used only for making the test script. + "", + ' ', + "\t", + ' ' + ); -sub SpecialCasing_txt() -{ - # - # Read in the special cases. - # +sub generate_separator($) { + # This used only for making the test script. It generates the colon or + # equal separator between the property and property value, with random + # white space surrounding the separator + + my $lhs = shift; - my %CaseInfo; + return "" if $lhs eq ""; # No separator if there's only one (the r) side - if (not open IN, "SpecialCasing.txt") { - die "$0: SpecialCasing.txt: $!\n"; + # Choose space before and after randomly + my $spaces_before =$white_space_separators[rand(@white_space_separators)]; + my $spaces_after = $white_space_separators[rand(@white_space_separators)]; + + # And return the whole complex, half the time using a colon, half the + # equals + return $spaces_before + . (rand() < 0.5) ? '=' : ':' + . $spaces_after; +} + +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. + + my $file_handle = shift; # Where to output the tests + 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 + # empty + my $invalid_code = shift; # A code point known to not be in the table; + # undef if the table is all code points + my $warning = shift; + + # Get the colon or equal + my $separator = generate_separator($lhs); + + # The whole 'property=value' + my $name = "$lhs$separator$rhs"; + + # Create a complete set of tests, with complements. + if (defined $valid_code) { + printf $file_handle + qq/Expect(1, $valid_code, '\\p{$name}', $warning);\n/; + printf $file_handle + qq/Expect(0, $valid_code, '\\p{^$name}', $warning);\n/; + printf $file_handle + qq/Expect(0, $valid_code, '\\P{$name}', $warning);\n/; + printf $file_handle + qq/Expect(1, $valid_code, '\\P{^$name}', $warning);\n/; + } + if (defined $invalid_code) { + printf $file_handle + qq/Expect(0, $invalid_code, '\\p{$name}', $warning);\n/; + printf $file_handle + qq/Expect(1, $invalid_code, '\\p{^$name}', $warning);\n/; + printf $file_handle + qq/Expect(1, $invalid_code, '\\P{$name}', $warning);\n/; + printf $file_handle + qq/Expect(0, $invalid_code, '\\P{^$name}', $warning);\n/; } - while (<IN>) { - next unless /^[0-9A-Fa-f]+;/; - s/\#.*//; - s/\s+$//; + return; +} - my ($code, $lower, $title, $upper, $condition) = split(/\s*;\s*/); +sub generate_error($$$$) { + # This used only for making the test script. It generates test cases that + # are expected to not only not match, but to be syntax or similar errors + + my $file_handle = shift; # Where to output to. + 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 $already_in_error = shift; # Boolean; if true it's known that the + # 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 + # loosely matched, again for convenience rather than rigor. + $rhs = randomize_loose_name($rhs, 'ERROR') unless $already_in_error; + + my $property = $lhs . $separator . $rhs; + + print $file_handle qq/Error('\\p{$property}');\n/; + print $file_handle qq/Error('\\P{$property}');\n/; + return; +} - if ($condition) { # not implemented yet - print "# SKIPPING $_\n" if $Verbose; - next; +# These are used only for making the test script +# XXX Maybe should also have a bad strict seps, which includes underscore. + +my @good_loose_seps = ( + " ", + "-", + "\t", + "", + "_", + ); +my @bad_loose_seps = ( + "/a/", + ':=', + ); + +sub randomize_stricter_name { + # This used only for making the test script. Take the input name and + # return a randomized, but valid version of it under the stricter matching + # rules. + + my $name = shift; + Carp::carp_extra_args(\@_) if main::DEBUG && @_; + + # If the name looks like a number (integer, floating, or rational), do + # some extra work + if ($name =~ qr{ ^ ( -? ) (\d+ ( ( [./] ) \d+ )? ) $ }x) { + my $sign = $1; + my $number = $2; + my $separator = $3; + + # If there isn't a sign, part of the time add a plus + # Note: Not testing having any denominator having a minus sign + if (! $sign) { + $sign = '+' if rand() <= .3; + } + + # And add 0 or more leading zeros. + $name = $sign . ('0' x int rand(10)) . $number; + + if (defined $separator) { + my $extra_zeros = '0' x int rand(10); + + if ($separator eq '.') { + + # Similarly, add 0 or more trailing zeros after a decimal + # point + $name .= $extra_zeros; + } + else { + + # Or, leading zeros before the denominator + $name =~ s,/,/$extra_zeros,; + } } + } - # Wait until all the special cases have been read since - # they are not listed in numeric order. - my $ix = hex($code); - push @{$CaseInfo{Lower}}, [ $ix, $code, $lower ] - unless $code eq $lower; - push @{$CaseInfo{Title}}, [ $ix, $code, $title ] - unless $code eq $title; - push @{$CaseInfo{Upper}}, [ $ix, $code, $upper ] - unless $code eq $upper; + # For legibility of the test, only change the case of whole sections at a + # time. To do this, first split into sections. The split returns the + # delimiters + my @sections; + for my $section (split / ( [ - + \s _ . ]+ ) /x, $name) { + trace $section if main::DEBUG && $to_trace; + + if (length $section > 1 && $section !~ /\D/) { + + # If the section is a sequence of digits, about half the time + # randomly add underscores between some of them. + if (rand() > .5) { + + # Figure out how many underscores to add. max is 1 less than + # the number of digits. (But add 1 at the end to make sure + # result isn't 0, and compensate earlier by subtracting 2 + # instead of 1) + my $num_underscores = int rand(length($section) - 2) + 1; + + # And add them evenly throughout, for convenience, not rigor + use integer; + my $spacing = (length($section) - 1)/ $num_underscores; + my $temp = $section; + $section = ""; + for my $i (1 .. $num_underscores) { + $section .= substr($temp, 0, $spacing, "") . '_'; + } + $section .= $temp; + } + push @sections, $section; + } + else { + + # Here not a sequence of digits. Change the case of the section + # randomly + my $switch = int rand(4); + if ($switch == 0) { + push @sections, uc $section; + } + elsif ($switch == 1) { + push @sections, lc $section; + } + elsif ($switch == 2) { + push @sections, ucfirst $section; + } + else { + push @sections, $section; + } + } } - close IN; + trace "returning", join "", @sections if main::DEBUG && $to_trace; + return join "", @sections; +} + +sub randomize_loose_name($;$) { + # This used only for making the test script + + my $name = shift; + my $want_error = shift; # if true, make an error + Carp::carp_extra_args(\@_) if main::DEBUG && @_; - # Now write out the special cases properties in their code point order. - # Prepend them to the To/{Upper,Lower,Title}.pl. + $name = randomize_stricter_name($name); + + my @parts; + push @parts, $good_loose_seps[rand(@good_loose_seps)]; + for my $part (split /[-\s_]+/, $name) { + if (@parts) { + if ($want_error and rand() < 0.3) { + push @parts, $bad_loose_seps[rand(@bad_loose_seps)]; + $want_error = 0; + } + else { + push @parts, $good_loose_seps[rand(@good_loose_seps)]; + } + } + push @parts, $part; + } + my $new = join("", @parts); + trace "$name => $new" if main::DEBUG && $to_trace; + + if ($want_error) { + if (rand() >= 0.5) { + $new .= $bad_loose_seps[rand(@bad_loose_seps)]; + } + else { + $new = $bad_loose_seps[rand(@bad_loose_seps)] . $new; + } + } + return $new; +} + +# Used to make sure don't generate duplicate test cases. +my %test_generated; + +sub make_property_test_script() { + # This used only for making the test script + # this written directly -- it's huge. + + print "Making test script\n" if $verbosity >= $PROGRESS; + + # This uses randomness to test different possibilities without testing all + # possibilities. To ensure repeatability, set the seed to 0. But if + # tests are added, it will perturb all later ones in the .t file + srand 0; + + $t_path = 'TestProp.pl' unless defined $t_path; # the traditional name + + force_unlink ($t_path); + push @files_actually_output, $t_path; + my $OUT; + if (not open $OUT, "> $t_path") { + Carp::my_carp("Can't open $t_path. Skipping: $!"); + return; + } - for my $case (qw(Lower Title Upper)) + # Keep going down an order of magnitude + # until find that adding this quantity to + # 1 remains 1; but put an upper limit on + # this so in case this algorithm doesn't + # work properly on some platform, that we + # won't loop forever. + my $digits = 0; + my $min_floating_slop = 1; + while (1+ $min_floating_slop != 1 + && $digits++ < 50) { - my $NormalCase = do "To/$case.pl" || die "$0: $@\n"; - - my @OUT = - ( - $HEADER, $INTERNAL_ONLY, "\n", - "# The key: UTF-8 _bytes_, the value: UTF-8 (speed hack)\n", - "%utf8::ToSpec$case =\n(\n", - ); - - for my $prop (sort { $a->[0] <=> $b->[0] } @{$CaseInfo{$case}}) { - my ($ix, $code, $to) = @$prop; - my $tostr = - join "", map { sprintf "\\x{%s}", $_ } split ' ', $to; - push @OUT, sprintf qq["%s" => "$tostr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $ix))); - # Remove any single-character mappings for - # the same character since we are going for - # the special casing rules. - $NormalCase =~ s/^$code\t\t\w+\n//m; - } - push @OUT, ( - ");\n\n", - "return <<'END';\n", - $NormalCase, - "END\n" - ); - WriteIfChanged(["To","$case.pl"], @OUT); + my $next = $min_floating_slop / 10; + last if $next == 0; # If underflows, + # use previous one + $min_floating_slop = $next; } + print $OUT $HEADER, <DATA>; + + foreach my $property (property_ref('*')) { + foreach my $table ($property->tables) { + + # Find code points that match, and don't match this table. + my $valid = $table->get_valid_code_point; + my $invalid = $table->get_invalid_code_point; + my $warning = ($table->status eq $DEPRECATED) + ? "'deprecated'" + : '""'; + + # Test each possible combination of the property's aliases with + # the table's. If this gets to be too many, could do what is done + # in the set_final_comment() for Tables + my @table_aliases = $table->aliases; + my @property_aliases = $table->property->aliases; + my $max = max(scalar @table_aliases, scalar @property_aliases); + for my $j (0 .. $max - 1) { + + # The current alias for property is the next one on the list, + # or if beyond the end, start over. Similarly for table + my $property_name + = $property_aliases[$j % @property_aliases]->name; + + $property_name = "" if $table->property == $perl; + my $table_alias = $table_aliases[$j % @table_aliases]; + my $table_name = $table_alias->name; + my $loose_match = $table_alias->loose_match; + + # If the table doesn't have a file, any test for it is + # already guaranteed to be in error + my $already_error = ! $table->file_path; + + # Generate error cases for this alias. + generate_error($OUT, + $property_name, + $table_name, + $already_error); + + # If the table is guaranteed to always generate an error, + # quit now without generating success cases. + next if $already_error; + + # Now for the success cases. + my $random; + if ($loose_match) { + + # For loose matching, create an extra test case for the + # standard name. + my $standard = standardize($table_name); + + # $test_name should be a unique combination for each test + # case; used just to avoid duplicate tests + my $test_name = "$property_name=$standard"; + + # Don't output duplicate test cases. + if (! exists $test_generated{$test_name}) { + $test_generated{$test_name} = 1; + generate_tests($OUT, + $property_name, + $standard, + $valid, + $invalid, + $warning, + ); + } + $random = randomize_loose_name($table_name) + } + else { # Stricter match + $random = randomize_stricter_name($table_name); + } + + # Now for the main test case for this alias. + my $test_name = "$property_name=$random"; + if (! exists $test_generated{$test_name}) { + $test_generated{$test_name} = 1; + generate_tests($OUT, + $property_name, + $random, + $valid, + $invalid, + $warning, + ); + + # If the name is a rational number, add tests for the + # floating point equivalent. + if ($table_name =~ qr{/}) { + + # Calculate the float, and find just the fraction. + my $float = eval $table_name; + my ($whole, $fraction) + = $float =~ / (.*) \. (.*) /x; + + # Starting with one digit after the decimal point, + # create a test for each possible precision (number of + # digits past the decimal point) until well beyond the + # native number found on this machine. (If we started + # with 0 digits, it would be an integer, which could + # well match an unrelated table) + PLACE: + for my $i (1 .. $min_floating_slop + 3) { + my $table_name = sprintf("%.*f", $i, $float); + if ($i < $MIN_FRACTION_LENGTH) { + + # If the test case has fewer digits than the + # minimum acceptable precision, it shouldn't + # succeed, so we expect an error for it. + # E.g., 2/3 = .7 at one decimal point, and we + # shouldn't say it matches .7. We should make + # it be .667 at least before agreeing that the + # intent was to match 2/3. But at the + # less-than- acceptable level of precision, it + # might actually match an unrelated number. + # So don't generate a test case if this + # conflating is possible. In our example, we + # don't want 2/3 matching 7/10, if there is + # a 7/10 code point. + for my $existing + (keys %nv_floating_to_rational) + { + next PLACE + if abs($table_name - $existing) + < $MAX_FLOATING_SLOP; + } + generate_error($OUT, + $property_name, + $table_name, + 1 # 1 => already an error + ); + } + else { + + # Here the number of digits exceeds the + # minimum we think is needed. So generate a + # success test case for it. + generate_tests($OUT, + $property_name, + $table_name, + $valid, + $invalid, + $warning, + ); + } + } + } + } + } + } + } + print $OUT "Finished();\n"; + close $OUT; + return; } +# This is a list of the input files and how to handle them. The files are +# processed in their order in this list. Some reordering is possible if +# desired, but the v0 files should be first, and the extracted before the +# others except DAge.txt (as data in an extracted file can be over-ridden by +# the non-extracted. Some other files depend on data derived from an earlier +# file, like UnicodeData requires data from Jamo, and the case changing and +# folding requires data from Unicode. Mostly, it safest to order by first +# version releases in (except the Jamo). DAge.txt is read before the +# extracted ones because of the rarely used feature $compare_versions. In the +# unlikely event that there were ever an extracted file that contained the Age +# property information, it would have to go in front of DAge. # -# Read in the case foldings. -# -# We will do full case folding, C + F + I (see CaseFolding.txt). Note that -# there are no I entries starting with Unicode 3.2, but leaving it in allows -# for backward compatibility. -# -sub CaseFolding_txt() -{ - if (not open IN, "CaseFolding.txt") { - die "$0: CaseFolding.txt: $!\n"; +# The version strings allow the program to know whether to expect a file or +# not, but if a file exists in the directory, it will be processed, even if it +# is in a version earlier than expected, so you can copy files from a later +# release into an earlier release's directory. +my @input_file_objects = ( + Input_file->new('PropertyAliases.txt', v0, + Handler => \&process_PropertyAliases, + ), + Input_file->new(undef, v0, # No file associated with this + Progress_Message => 'Finishing property setup', + Handler => \&finish_property_setup, + ), + Input_file->new('PropValueAliases.txt', v0, + Handler => \&process_PropValueAliases, + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new('DAge.txt', v3.2.0, + Has_Missings_Defaults => $NOT_IGNORED, + Property => 'Age' + ), + Input_file->new("${EXTRACTED}DGeneralCategory.txt", v3.1.0, + Property => 'General_Category', + ), + Input_file->new("${EXTRACTED}DCombiningClass.txt", v3.1.0, + Property => 'Canonical_Combining_Class', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("${EXTRACTED}DNumType.txt", v3.1.0, + Property => 'Numeric_Type', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("${EXTRACTED}DEastAsianWidth.txt", v3.1.0, + Property => 'East_Asian_Width', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("${EXTRACTED}DLineBreak.txt", v3.1.0, + Property => 'Line_Break', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("${EXTRACTED}DBidiClass.txt", v3.1.1, + Property => 'Bidi_Class', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("${EXTRACTED}DDecompositionType.txt", v3.1.0, + Property => 'Decomposition_Type', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("${EXTRACTED}DBinaryProperties.txt", v3.1.0), + Input_file->new("${EXTRACTED}DNumValues.txt", v3.1.0, + Property => 'Numeric_Value', + Each_Line_Handler => \&filter_numeric_value_line, + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("${EXTRACTED}DJoinGroup.txt", v3.1.0, + Property => 'Joining_Group', + Has_Missings_Defaults => $NOT_IGNORED, + ), + + Input_file->new("${EXTRACTED}DJoinType.txt", v3.1.0, + Property => 'Joining_Type', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new('Jamo.txt', v2.0.0, + Property => 'Jamo_Short_Name', + Each_Line_Handler => \&filter_jamo_line, + ), + Input_file->new('UnicodeData.txt', v1.1.5, + Pre_Handler => \&setup_UnicodeData, + + # We clean up this file for some early versions. + Each_Line_Handler => [ (($v_version lt v2.0.0 ) + ? \&filter_v1_ucd + : ($v_version eq v2.1.5) + ? \&filter_v2_1_5_ucd + : undef), + + # And the main filter + \&filter_UnicodeData_line, + ], + EOF_Handler => \&EOF_UnicodeData, + ), + Input_file->new('ArabicShaping.txt', v2.0.0, + Each_Line_Handler => + [ ($v_version lt 4.1.0) + ? \&filter_old_style_arabic_shaping + : undef, + \&filter_arabic_shaping_line, + ], + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new('Blocks.txt', v2.0.0, + Property => 'Block', + Has_Missings_Defaults => $NOT_IGNORED, + Each_Line_Handler => \&filter_blocks_lines + ), + Input_file->new('PropList.txt', v2.0.0, + Each_Line_Handler => (($v_version lt v3.1.0) + ? \&filter_old_style_proplist + : undef), + ), + Input_file->new('Unihan.txt', v2.0.0, + Pre_Handler => \&setup_unihan, + Optional => 1, + Each_Line_Handler => \&filter_unihan_line, + ), + Input_file->new('SpecialCasing.txt', v2.1.8, + Each_Line_Handler => \&filter_special_casing_line, + Pre_Handler => \&setup_special_casing, + ), + Input_file->new( + 'LineBreak.txt', v3.0.0, + Has_Missings_Defaults => $NOT_IGNORED, + Property => 'Line_Break', + # Early versions had problematic syntax + Each_Line_Handler => (($v_version lt v3.1.0) + ? \&filter_early_ea_lb + : undef), + ), + Input_file->new('EastAsianWidth.txt', v3.0.0, + Property => 'East_Asian_Width', + Has_Missings_Defaults => $NOT_IGNORED, + # Early versions had problematic syntax + Each_Line_Handler => (($v_version lt v3.1.0) + ? \&filter_early_ea_lb + : undef), + ), + Input_file->new('CompositionExclusions.txt', v3.0.0, + Property => 'Composition_Exclusion', + ), + Input_file->new('BidiMirroring.txt', v3.0.1, + Property => 'Bidi_Mirroring_Glyph', + ), + Input_file->new('CaseFolding.txt', v3.0.1, + Pre_Handler => \&setup_case_folding, + Each_Line_Handler => + [ ($v_version lt v3.1.0) + ? \&filter_old_style_case_folding + : undef, + \&filter_case_folding_line + ], + Post_Handler => \&post_fold, + ), + Input_file->new('DCoreProperties.txt', v3.1.0, + # 5.2 changed this file + Has_Missings_Defaults => (($v_version ge v5.2.0) + ? $NOT_IGNORED + : $NO_DEFAULTS), + ), + Input_file->new('Scripts.txt', v3.1.0, + Property => 'Script', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new('DNormalizationProps.txt', v3.1.0, + Has_Missings_Defaults => $NOT_IGNORED, + Each_Line_Handler => (($v_version lt v4.0.1) + ? \&filter_old_style_normalization_lines + : undef), + ), + Input_file->new('HangulSyllableType.txt', v4.0.0, + Has_Missings_Defaults => $NOT_IGNORED, + Property => 'Hangul_Syllable_Type'), + Input_file->new("$AUXILIARY/WordBreakProperty.txt", v4.1.0, + Property => 'Word_Break', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("$AUXILIARY/GraphemeBreakProperty.txt", v4.1.0, + Property => 'Grapheme_Cluster_Break', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new("$AUXILIARY/SentenceBreakProperty.txt", v4.1.0, + Property => 'Sentence_Break', + Has_Missings_Defaults => $NOT_IGNORED, + ), + Input_file->new('NamedSequences.txt', v4.1.0, + Handler => \&process_NamedSequences + ), + Input_file->new('NameAliases.txt', v5.0.0, + Property => 'Name_Alias', + ), + Input_file->new('UnihanIndicesDictionary.txt', v5.2.0, + Optional => 1, + Each_Line_Handler => \&filter_unihan_line, + ), + Input_file->new('UnihanDataDictionaryLike.txt', v5.2.0, + Optional => 1, + Each_Line_Handler => \&filter_unihan_line, + ), + Input_file->new('UnihanIRGSources.txt', v5.2.0, + Optional => 1, + Pre_Handler => \&setup_unihan, + Each_Line_Handler => \&filter_unihan_line, + ), + Input_file->new('UnihanNumericValues.txt', v5.2.0, + Optional => 1, + Each_Line_Handler => \&filter_unihan_line, + ), + Input_file->new('UnihanOtherMappings.txt', v5.2.0, + Optional => 1, + Each_Line_Handler => \&filter_unihan_line, + ), + Input_file->new('UnihanRadicalStrokeCounts.txt', v5.2.0, + Optional => 1, + Each_Line_Handler => \&filter_unihan_line, + ), + Input_file->new('UnihanReadings.txt', v5.2.0, + Optional => 1, + Each_Line_Handler => \&filter_unihan_line, + ), + Input_file->new('UnihanVariants.txt', v5.2.0, + Optional => 1, + Each_Line_Handler => \&filter_unihan_line, + ), +); + +# End of all the preliminaries. +# Do it... + +if ($compare_versions) { + Carp::my_carp(<<END +Warning. \$compare_versions is set. Output is not suitable for production +END + ); +} + +# Put into %potential_files a list of all the files in the directory structure +# that could be inputs to this program, excluding those that we should ignore. +# Also don't consider test files. Use absolute file names because it makes it +# easier across machine types. +my @ignored_files_full_names = map { File::Spec->rel2abs( + internal_file_to_platform($_)) + } keys %ignored_files; +File::Find::find({ + wanted=>sub { + return unless /\.txt$/i; + return if /Test\.txt$/i; + my $full = File::Spec->rel2abs($_); + $potential_files{$full} = 1 + if ! grep { $full eq $_ } @ignored_files_full_names; + return; } +}, File::Spec->curdir()); - my $Fold = Table->New(); - my %Fold; +my @mktables_list_output_files; - while (<IN>) { - # Skip status 'S', simple case folding - next unless /^([0-9A-Fa-f]+)\s*;\s*([CFI])\s*;\s*([0-9A-Fa-f]+(?: [0-9A-Fa-f]+)*)\s*;/; +if ($write_unchanged_files) { + print "Not checking file list '$file_list'.\n" if $verbosity >= $VERBOSE; +} +else { + print "Reading file list '$file_list'\n" if $verbosity >= $VERBOSE; + my $file_handle; + if (! open $file_handle, "<", $file_list) { + Carp::my_carp("Failed to open '$file_list' (this is expected to be missing the first time); turning on -globlist option instead: $!"); + $glob_list = 1; + } + else { + my @input; + + # Read and parse mktables.lst, placing the results from the first part + # into @input, and the second part into @mktables_list_output_files + for my $list ( \@input, \@mktables_list_output_files ) { + while (<$file_handle>) { + s/^ \s+ | \s+ $//xg; + next if /^ \s* (?: \# .* )? $/x; + last if /^ =+ $/x; + my ( $file ) = split /\t/; + push @$list, $file; + } + @$list = uniques(@$list); + next; + } - my ($code, $status, $fold) = (hex($1), $2, $3); + # Look through all the input files + foreach my $input (@input) { + next if $input eq 'version'; # Already have checked this. - if ($status eq 'C') { # Common: one-to-one folding - # No append() since several codes may fold into one. - $Fold->RawAppendRange($code, $code, $fold); - } else { # F: full, or I: dotted uppercase I -> dotless lowercase I - $Fold{$code} = $fold; - } + # Ignore if doesn't exist. The checking about whether we care or + # not is done via the Input_file object. + next if ! file_exists($input); + + # The paths are stored with relative names, and with '/' as the + # delimiter; convert to absolute on this machine + my $full = File::Spec->rel2abs(internal_file_to_platform($input)); + $potential_files{$full} = 1 + if ! grep { $full eq $_ } @ignored_files_full_names; + } } - close IN; - $Fold->Write("To/Fold.pl"); + close $file_handle; +} - # - # Prepend the special foldings to the common foldings. - # - my $CommonFold = do "To/Fold.pl" || die "$0: To/Fold.pl: $!\n"; - - my @OUT = - ( - $HEADER, $INTERNAL_ONLY, "\n", - "# The key: UTF-8 _bytes_, the value: UTF-8 (speed hack)\n", - "%utf8::ToSpecFold =\n(\n", - ); - for my $code (sort { $a <=> $b } keys %Fold) { - my $foldstr = - join "", map { sprintf "\\x{%s}", $_ } split ' ', $Fold{$code}; - push @OUT, sprintf qq["%s" => "$foldstr",\n], join("", map { sprintf "\\x%02X", $_ } unpack("U0C*", pack("U", $code))); - } - push @OUT, ( - ");\n\n", - "return <<'END';\n", - $CommonFold, - "END\n", - ); - - WriteIfChanged(["To","Fold.pl"], @OUT); -} - -## Do it.... - -Build_Aliases(); -UnicodeData_Txt(); -PropList_txt(); - -Scripts_txt(); -Blocks_txt(); - -WriteAllMappings(); - -LineBreak_Txt(); -ArabicShaping_txt(); -EastAsianWidth_txt(); -HangulSyllableType_txt(); -Jamo_txt(); -SpecialCasing_txt(); -CaseFolding_txt(); - -if ( $FileList and $MakeList ) { - - print "Updating '$FileList'\n" - if ($Verbose); - - open my $ofh,">",$FileList - or die "Can't write to '$FileList':$!"; - print $ofh <<"EOFHEADER"; +if ($glob_list) { + + # Here wants to process all .txt files in the directory structure. + # Convert them to full path names. They are stored in the platform's + # relative style + my @known_files; + foreach my $object (@input_file_objects) { + my $file = $object->file; + next unless defined $file; + push @known_files, File::Spec->rel2abs($file); + } + + my @unknown_input_files; + foreach my $file (keys %potential_files) { + next if grep { $file eq $_ } @known_files; + + # Here, the file is unknown to us. Get relative path name + $file = File::Spec->abs2rel($file); + push @unknown_input_files, $file; + + # What will happen is we create a data structure for it, and add it to + # the list of input files to process. First get the subdirectories + # into an array + my (undef, $directories, undef) = File::Spec->splitpath($file); + $directories =~ s;/$;;; # Can have extraneous trailing '/' + my @directories = File::Spec->splitdir($directories); + + # If the file isn't extracted (meaning none of the directories is the + # extracted one), just add it to the end of the list of inputs. + if (! grep { $EXTRACTED_DIR eq $_ } @directories) { + push @input_file_objects, Input_file->new($file); + } + else { + + # Here, the file is extracted. It needs to go ahead of most other + # processing. Search for the first input file that isn't a + # special required property (that is, find one whose first_release + # is non-0), and isn't extracted. Also, the Age property file is + # processed before the extracted ones, just in case + # $compare_versions is set. + for (my $i = 0; $i < @input_file_objects; $i++) { + if ($input_file_objects[$i]->first_released ne v0 + && $input_file_objects[$i]->file ne 'DAge.txt' + && $input_file_objects[$i]->file !~ /$EXTRACTED_DIR/) + { + splice @input_file_objects, $i, 0, Input_file->new($file); + last; + } + } + + } + } + if (@unknown_input_files) { + print STDERR simple_fold(join_lines(<<END + +The following files are unknown as to how to handle. Assuming they are +typical property files. You'll know by later error messages if it worked or +not: +END + ) . join(", ", @unknown_input_files) . "\n\n"); + } +} # End of looking through directory structure for more .txt files. + +# Create the list of input files from the objects we have defined, plus +# version +my @input_files = 'version'; +foreach my $object (@input_file_objects) { + my $file = $object->file; + next if ! defined $file; # Not all objects have files + next if $object->optional && ! -e $file; + push @input_files, $file; +} + +if ( $verbosity >= $VERBOSE ) { + print "Expecting ".scalar( @input_files )." input files. ", + "Checking ".scalar( @mktables_list_output_files )." output files.\n"; +} + +# We set $youngest to be the most recently changed input file, including this +# program itself (done much earlier in this file) +foreach my $in (@input_files) { + my $age = -M $in; + next unless defined $age; # Keep going even if missing a file + $youngest = $age if $age < $youngest; + + # See that the input files have distinct names, to warn someone if they + # are adding a new one + if ($make_list) { + my ($volume, $directories, $file ) = File::Spec->splitpath($in); + $directories =~ s;/$;;; # Can have extraneous trailing '/' + my @directories = File::Spec->splitdir($directories); + my $base = $file =~ s/\.txt$//; + construct_filename($file, 'mutable', \@directories); + } +} + +my $ok = ! $write_unchanged_files + && scalar @mktables_list_output_files; # If none known, rebuild + +# Now we check to see if any output files are older than youngest, if +# they are, we need to continue on, otherwise we can presumably bail. +if ($ok) { + foreach my $out (@mktables_list_output_files) { + if ( ! file_exists($out)) { + print "'$out' is missing.\n" if $verbosity >= $VERBOSE; + $ok = 0; + last; + } + #local $to_trace = 1 if main::DEBUG; + trace $youngest, -M $out if main::DEBUG && $to_trace; + if ( -M $out > $youngest ) { + #trace "$out: age: ", -M $out, ", youngest: $youngest\n" if main::DEBUG && $to_trace; + print "'$out' is too old.\n" if $verbosity >= $VERBOSE; + $ok = 0; + last; + } + } +} +if ($ok) { + print "Files seem to be ok, not bothering to rebuild.\n"; + exit(0); +} +print "Must rebuild tables.\n" if $verbosity >= $VERBOSE; + +# Ready to do the major processing. First create the perl pseudo-property. +$perl = Property->new('perl', Type => $NON_STRING, Perl_Extension => 1); + +# Process each input file +foreach my $file (@input_file_objects) { + $file->run; +} + +# Finish the table generation. + +print "Finishing processing Unicode properties\n" if $verbosity >= $PROGRESS; +finish_Unicode(); + +print "Compiling Perl properties\n" if $verbosity >= $PROGRESS; +compile_perl(); + +print "Creating Perl synonyms\n" if $verbosity >= $PROGRESS; +add_perl_synonyms(); + +print "Writing tables\n" if $verbosity >= $PROGRESS; +write_all_tables(); + +# Write mktables.lst +if ( $file_list and $make_list ) { + + print "Updating '$file_list'\n" if $verbosity >= $PROGRESS; + foreach my $file (@input_files, @files_actually_output) { + my (undef, $directories, $file) = File::Spec->splitpath($file); + my @directories = File::Spec->splitdir($directories); + $file = join '/', @directories, $file; + } + + my $ofh; + if (! open $ofh,">",$file_list) { + Carp::my_carp("Can't write to '$file_list'. Skipping: $!"); + return + } + else { + print $ofh <<"END"; # -# mktables.lst -- File list for mktables. +# $file_list -- File list for $0. # # Autogenerated on @{[scalar localtime]} # # - First section is input files -# (mktables itself is automatically included) +# ($0 itself is not listed but is automatically considered an input) # - Section seperator is /^=+\$/ # - Second section is a list of output files. # - Lines matching /^\\s*#/ are treated as comments @@ -2235,91 +13703,172 @@ if ( $FileList and $MakeList ) { # Input files: -EOFHEADER - my @input=("version",glob('*.txt')); - print $ofh "$_\n" for - sort(@input), - "\n=================================\n", - "# Output files:\n", - # special files - "Properties"; - - - require File::Find; - my @output_files; - File::Find::find({ - no_chdir=>1, - wanted=>sub { - if (/\.pl$/) { - s!^\./!!; - push @output_files, "$_\n"; - } - }, - },"."); - - print $ofh sort @output_files; - print $ofh "\n# ",scalar(@input)," input files\n", - "# ",scalar(@output_files)+1," output files\n\n", - "# End list\n"; - close $ofh - or warn "Failed to close $ofh: $!"; - - print "Filelist has ",scalar(@input)," input files and ", - scalar(@output_files)+1," output files\n" - if $Verbose; -} -print "All done\n" if $Verbose; +END + print $ofh "$_\n" for sort(@input_files); + print $ofh "\n=================================\n# Output files:\n\n"; + print $ofh "$_\n" for sort @files_actually_output; + print $ofh "\n# ",scalar(@input_files)," input files\n", + "# ",scalar(@files_actually_output)+1," output files\n\n", + "# End list\n"; + close $ofh + or Carp::my_carp("Failed to close $ofh: $!"); + + print "Filelist has ",scalar(@input_files)," input files and ", + scalar(@files_actually_output)+1," output files\n" + if $verbosity >= $VERBOSE; + } +} + +# Output these warnings unless -q explicitly specified. +if ($verbosity >= $NORMAL_VERBOSITY) { + if (@unhandled_properties) { + print "\nProperties and tables that unexpectedly have no code points\n"; + foreach my $property (sort @unhandled_properties) { + print $property, "\n"; + } + } + + if (%potential_files) { + print "\nInput files that are not considered:\n"; + foreach my $file (sort keys %potential_files) { + print File::Spec->abs2rel($file), "\n"; + } + } + print "\nAll done\n" if $verbosity >= $VERBOSE; +} exit(0); -## TRAILING CODE IS USED BY MakePropTestScript() +# TRAILING CODE IS USED BY make_property_test_script() __DATA__ + use strict; use warnings; +# Test the \p{} regular expression constructs. This file is constructed by +# mktables from the tables it generates, so if mktables is buggy, this won't +# necessarily catch those bugs. Tests are generated for all feasible +# properties; a few aren't currently feasible; see is_code_point_usable() +# in mktables for details. + +# Standard test packages are not used because this manipulates SIG_WARN. It +# exits 0 if every non-skipped test succeeded; -1 if any failed. + my $Tests = 0; my $Fails = 0; +my $Skips = 0; + +my $non_ASCII = (ord('A') == 65); + +# The first 127 ASCII characters in ordinal order, with the ones that don't +# have Perl names (as of 5.8) replaced by dots. The 127th is used as the +# string delimiter +my $ascii_to_ebcdic = "\0......\a\b\t\n.\f\r.................. !\"#\$\%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"; +#for my $i (0..126) { +# print $i, ": ", substr($ascii_to_ebcdic, $i, 1), "\n"; +#} + +sub Expect($$$$) { + my $expected = shift; + my $ord = shift; + my $regex = shift; + my $warning_type = shift; # Type of warning message, like 'deprecated' + # or empty if none + my $line = (caller)[2]; + + # Convert the code point to hex form + my $string = sprintf "\"\\x{%04X}\"", $ord; + + # Convert the non-ASCII code points expressible as characters in Perl 5.8 + # to their ASCII equivalents, and skip the others. + if ($non_ASCII && $ord < 255) { + + # Dots are used as place holders in the conversion string for the + # non-convertible ones, so check for it first. + if ($ord == 0x2E) { + $ord = ord('.'); + } + elsif ($ord < 0x7F + # Any dots returned are non-convertible. + && ((my $char = substr($ascii_to_ebcdic, $ord, 1)) ne '.')) + { + #print STDERR "$ord, $char, \n"; + $ord = ord($char); + } + else { + $Tests++; + $Skips++; + print "ok $Tests - $string =~ $regex # Skipped: non-ASCII\n"; + return; + } + } -sub Expect($$$) -{ - my $Expect = shift; - my $String = shift; - my $Regex = shift; - my $Line = (caller)[2]; + # The first time through, use all warnings. + my @tests = ""; - $Tests++; - my $RegObj; - my $result = eval { - $RegObj = qr/$Regex/; - $String =~ $RegObj ? 1 : 0 - }; - - if (not defined $result) { - print "couldn't compile /$Regex/ on $0 line $Line: $@\n"; - $Fails++; - } elsif ($result ^ $Expect) { - print "bad result (expected $Expect) on $0 line $Line: $@\n"; - $Fails++; + # If the input should generate a warning, add another time through with + # them turned off + push @tests, "no warnings '$warning_type';" if $warning_type; + + foreach my $no_warnings (@tests) { + + # Store any warning messages instead of outputting them + local $SIG{__WARN__} = $SIG{__WARN__}; + my $warning_message; + $SIG{__WARN__} = sub { $warning_message = $_[0] }; + + $Tests++; + + # A string eval is needed because of the 'no warnings'. + # Assumes no parens in the regular expression + my $result = eval "$no_warnings + my \$RegObj = qr($regex); + $string =~ \$RegObj ? 1 : 0"; + if (not defined $result) { + print "not ok $Tests - couldn't compile /$regex/; line $line: $@\n"; + $Fails++; + } + elsif ($result ^ $expected) { + print "not ok $Tests - expected $expected but got $result for $string =~ qr/$regex/; line $line\n"; + $Fails++; + } + elsif ($warning_message) { + if (! $warning_type || ($warning_type && $no_warnings)) { + print "not ok $Tests - for qr/$regex/ did not expect warning message '$warning_message'; line $line\n"; + $Fails++; + } + else { + print "ok $Tests - expected and got a warning message for qr/$regex/; line $line\n"; + } + } + elsif ($warning_type && ! $no_warnings) { + print "not ok $Tests - for qr/$regex/ expected a $warning_type warning message, but got none; line $line\n"; + $Fails++; + } + else { + print "ok $Tests - got $result for $string =~ qr/$regex/; line $line\n"; + } } + return; } -sub Error($) -{ - my $Regex = shift; +sub Error($) { + my $regex = shift; $Tests++; - if (eval { 'x' =~ qr/$Regex/; 1 }) { + if (eval { 'x' =~ qr/$regex/; 1 }) { $Fails++; - my $Line = (caller)[2]; - print "expected error for /$Regex/ on $0 line $Line: $@\n"; + my $line = (caller)[2]; + print "not ok $Tests - re compiled ok, but expected error for qr/$regex/; line $line: $@\n"; } + else { + my $line = (caller)[2]; + print "ok $Tests - got and expected error for qr/$regex/; line $line\n"; + } + return; } -sub Finished() -{ - if ($Fails == 0) { - print "All $Tests tests passed.\n"; - exit(0); - } else { - print "$Tests tests, $Fails failed!\n"; - exit(-1); - } +sub Finished() { + print "1..$Tests\n"; + exit($Fails ? -1 : 0); } + +Error('\p{Script=InGreek}'); # Bug #69018 diff --git a/lib/unicore/mktables.lst b/lib/unicore/mktables.lst deleted file mode 100644 index f4c55bb64e..0000000000 --- a/lib/unicore/mktables.lst +++ /dev/null @@ -1,563 +0,0 @@ -# -# mktables.lst -- File list for mktables. -# -# Autogenerated on Mon Jan 26 17:57:26 2009 -# -# - First section is input files -# (mktables itself is automatically included) -# - Section seperator is /^=+$/ -# - Second section is a list of output files. -# - Lines matching /^\s*#/ are treated as comments -# which along with blank lines are ignored. -# - -# Input files: - -ArabicShaping.txt -BidiMirroring.txt -Blocks.txt -CaseFolding.txt -CompositionExclusions.txt -EastAsianWidth.txt -HangulSyllableType.txt -Index.txt -Jamo.txt -LineBreak.txt -NameAliases.txt -NamedSequences.txt -NamedSqProv.txt -NamesList.txt -NormalizationCorrections.txt -PropList.txt -PropValueAliases.txt -PropertyAliases.txt -ReadMe.txt -Scripts.txt -SpecialCasing.txt -StandardizedVariants.txt -UnicodeData.txt -version - -================================= - -# Output files: - -Properties -Canonical.pl -CombiningClass.pl -Decomposition.pl -Exact.pl -Name.pl -PVA.pl -To/Digit.pl -To/Fold.pl -To/Lower.pl -To/Title.pl -To/Upper.pl -lib/bc/AL.pl -lib/bc/AN.pl -lib/bc/B.pl -lib/bc/BN.pl -lib/bc/CS.pl -lib/bc/EN.pl -lib/bc/ES.pl -lib/bc/ET.pl -lib/bc/L.pl -lib/bc/LRE.pl -lib/bc/LRO.pl -lib/bc/NSM.pl -lib/bc/ON.pl -lib/bc/PDF.pl -lib/bc/R.pl -lib/bc/RLE.pl -lib/bc/RLO.pl -lib/bc/S.pl -lib/bc/WS.pl -lib/ccc/A.pl -lib/ccc/AL.pl -lib/ccc/AR.pl -lib/ccc/ATAR.pl -lib/ccc/ATB.pl -lib/ccc/ATBL.pl -lib/ccc/B.pl -lib/ccc/BL.pl -lib/ccc/BR.pl -lib/ccc/DA.pl -lib/ccc/DB.pl -lib/ccc/IS.pl -lib/ccc/KV.pl -lib/ccc/L.pl -lib/ccc/NK.pl -lib/ccc/NR.pl -lib/ccc/OV.pl -lib/ccc/R.pl -lib/ccc/VR.pl -lib/dt/Can.pl -lib/dt/Com.pl -lib/dt/Enc.pl -lib/dt/Fin.pl -lib/dt/Font.pl -lib/dt/Fra.pl -lib/dt/Init.pl -lib/dt/Iso.pl -lib/dt/Med.pl -lib/dt/Nar.pl -lib/dt/Nb.pl -lib/dt/Sml.pl -lib/dt/Sqr.pl -lib/dt/Sub.pl -lib/dt/Sup.pl -lib/dt/Vert.pl -lib/dt/Wide.pl -lib/ea/A.pl -lib/ea/F.pl -lib/ea/H.pl -lib/ea/N.pl -lib/ea/Na.pl -lib/ea/W.pl -lib/gc_sc/AHex.pl -lib/gc_sc/ASCII.pl -lib/gc_sc/Alnum.pl -lib/gc_sc/Alpha.pl -lib/gc_sc/Alphabet.pl -lib/gc_sc/Any.pl -lib/gc_sc/Arab.pl -lib/gc_sc/Armn.pl -lib/gc_sc/AsciiHex.pl -lib/gc_sc/Assigned.pl -lib/gc_sc/Bali.pl -lib/gc_sc/Beng.pl -lib/gc_sc/BidiC.pl -lib/gc_sc/BidiCont.pl -lib/gc_sc/Blank.pl -lib/gc_sc/Bopo.pl -lib/gc_sc/Brai.pl -lib/gc_sc/Bugi.pl -lib/gc_sc/Buhd.pl -lib/gc_sc/C.pl -lib/gc_sc/Canadian.pl -lib/gc_sc/Cari.pl -lib/gc_sc/Cc.pl -lib/gc_sc/Cf.pl -lib/gc_sc/Cham.pl -lib/gc_sc/Cher.pl -lib/gc_sc/Cn.pl -lib/gc_sc/Cntrl.pl -lib/gc_sc/Co.pl -lib/gc_sc/Copt.pl -lib/gc_sc/Cprt.pl -lib/gc_sc/Cs.pl -lib/gc_sc/Cyrl.pl -lib/gc_sc/Dash.pl -lib/gc_sc/Dash2.pl -lib/gc_sc/DefaultI.pl -lib/gc_sc/Dep.pl -lib/gc_sc/Deprecat.pl -lib/gc_sc/Deva.pl -lib/gc_sc/Dia.pl -lib/gc_sc/Diacriti.pl -lib/gc_sc/Digit.pl -lib/gc_sc/Dsrt.pl -lib/gc_sc/Ethi.pl -lib/gc_sc/Ext.pl -lib/gc_sc/Extender.pl -lib/gc_sc/Geor.pl -lib/gc_sc/Glag.pl -lib/gc_sc/Goth.pl -lib/gc_sc/Graph.pl -lib/gc_sc/Grek.pl -lib/gc_sc/Gujr.pl -lib/gc_sc/Guru.pl -lib/gc_sc/Hang.pl -lib/gc_sc/Hani.pl -lib/gc_sc/Hano.pl -lib/gc_sc/Hebr.pl -lib/gc_sc/Hex.pl -lib/gc_sc/HexDigit.pl -lib/gc_sc/Hira.pl -lib/gc_sc/HorizSpa.pl -lib/gc_sc/Hyphen.pl -lib/gc_sc/Hyphen2.pl -lib/gc_sc/IDSB.pl -lib/gc_sc/IDST.pl -lib/gc_sc/IdContin.pl -lib/gc_sc/IdStart.pl -lib/gc_sc/Ideo.pl -lib/gc_sc/Ideograp.pl -lib/gc_sc/IdsBinar.pl -lib/gc_sc/IdsTrina.pl -lib/gc_sc/InAegean.pl -lib/gc_sc/InAlphab.pl -lib/gc_sc/InAncie2.pl -lib/gc_sc/InAncie3.pl -lib/gc_sc/InAncien.pl -lib/gc_sc/InArabi2.pl -lib/gc_sc/InArabi3.pl -lib/gc_sc/InArabi4.pl -lib/gc_sc/InArabic.pl -lib/gc_sc/InArmeni.pl -lib/gc_sc/InArrows.pl -lib/gc_sc/InBaline.pl -lib/gc_sc/InBasicL.pl -lib/gc_sc/InBengal.pl -lib/gc_sc/InBlockE.pl -lib/gc_sc/InBopom2.pl -lib/gc_sc/InBopomo.pl -lib/gc_sc/InBoxDra.pl -lib/gc_sc/InBraill.pl -lib/gc_sc/InBugine.pl -lib/gc_sc/InBuhid.pl -lib/gc_sc/InByzant.pl -lib/gc_sc/InCarian.pl -lib/gc_sc/InCham.pl -lib/gc_sc/InCherok.pl -lib/gc_sc/InCjkCo2.pl -lib/gc_sc/InCjkCo3.pl -lib/gc_sc/InCjkCo4.pl -lib/gc_sc/InCjkCom.pl -lib/gc_sc/InCjkRad.pl -lib/gc_sc/InCjkStr.pl -lib/gc_sc/InCjkSym.pl -lib/gc_sc/InCjkUn2.pl -lib/gc_sc/InCjkUn3.pl -lib/gc_sc/InCjkUni.pl -lib/gc_sc/InCombi2.pl -lib/gc_sc/InCombi3.pl -lib/gc_sc/InCombi4.pl -lib/gc_sc/InCombin.pl -lib/gc_sc/InContro.pl -lib/gc_sc/InCoptic.pl -lib/gc_sc/InCounti.pl -lib/gc_sc/InCunei2.pl -lib/gc_sc/InCuneif.pl -lib/gc_sc/InCurren.pl -lib/gc_sc/InCyprio.pl -lib/gc_sc/InCyril2.pl -lib/gc_sc/InCyril3.pl -lib/gc_sc/InCyril4.pl -lib/gc_sc/InCyrill.pl -lib/gc_sc/InDesere.pl -lib/gc_sc/InDevana.pl -lib/gc_sc/InDingba.pl -lib/gc_sc/InDomino.pl -lib/gc_sc/InEnclo2.pl -lib/gc_sc/InEnclos.pl -lib/gc_sc/InEthio2.pl -lib/gc_sc/InEthio3.pl -lib/gc_sc/InEthiop.pl -lib/gc_sc/InGenera.pl -lib/gc_sc/InGeomet.pl -lib/gc_sc/InGeorg2.pl -lib/gc_sc/InGeorgi.pl -lib/gc_sc/InGlagol.pl -lib/gc_sc/InGothic.pl -lib/gc_sc/InGreekA.pl -lib/gc_sc/InGreekE.pl -lib/gc_sc/InGujara.pl -lib/gc_sc/InGurmuk.pl -lib/gc_sc/InHalfwi.pl -lib/gc_sc/InHangu2.pl -lib/gc_sc/InHangu3.pl -lib/gc_sc/InHangul.pl -lib/gc_sc/InHanuno.pl -lib/gc_sc/InHebrew.pl -lib/gc_sc/InHighPr.pl -lib/gc_sc/InHighSu.pl -lib/gc_sc/InHiraga.pl -lib/gc_sc/InIdeogr.pl -lib/gc_sc/InIpaExt.pl -lib/gc_sc/InKanbun.pl -lib/gc_sc/InKangxi.pl -lib/gc_sc/InKannad.pl -lib/gc_sc/InKatak2.pl -lib/gc_sc/InKataka.pl -lib/gc_sc/InKayahL.pl -lib/gc_sc/InKharos.pl -lib/gc_sc/InKhmer.pl -lib/gc_sc/InKhmerS.pl -lib/gc_sc/InLao.pl -lib/gc_sc/InLatin1.pl -lib/gc_sc/InLatin2.pl -lib/gc_sc/InLatin3.pl -lib/gc_sc/InLatin4.pl -lib/gc_sc/InLatin5.pl -lib/gc_sc/InLatinE.pl -lib/gc_sc/InLepcha.pl -lib/gc_sc/InLetter.pl -lib/gc_sc/InLimbu.pl -lib/gc_sc/InLinea2.pl -lib/gc_sc/InLinear.pl -lib/gc_sc/InLowSur.pl -lib/gc_sc/InLycian.pl -lib/gc_sc/InLydian.pl -lib/gc_sc/InMahjon.pl -lib/gc_sc/InMalaya.pl -lib/gc_sc/InMathe2.pl -lib/gc_sc/InMathem.pl -lib/gc_sc/InMisce2.pl -lib/gc_sc/InMisce3.pl -lib/gc_sc/InMisce4.pl -lib/gc_sc/InMisce5.pl -lib/gc_sc/InMiscel.pl -lib/gc_sc/InModifi.pl -lib/gc_sc/InMongol.pl -lib/gc_sc/InMusica.pl -lib/gc_sc/InMyanma.pl -lib/gc_sc/InNewTai.pl -lib/gc_sc/InNko.pl -lib/gc_sc/InNumber.pl -lib/gc_sc/InOgham.pl -lib/gc_sc/InOlChik.pl -lib/gc_sc/InOldIta.pl -lib/gc_sc/InOldPer.pl -lib/gc_sc/InOptica.pl -lib/gc_sc/InOriya.pl -lib/gc_sc/InOsmany.pl -lib/gc_sc/InPhagsP.pl -lib/gc_sc/InPhaist.pl -lib/gc_sc/InPhoeni.pl -lib/gc_sc/InPhone2.pl -lib/gc_sc/InPhonet.pl -lib/gc_sc/InPrivat.pl -lib/gc_sc/InRejang.pl -lib/gc_sc/InRunic.pl -lib/gc_sc/InSauras.pl -lib/gc_sc/InShavia.pl -lib/gc_sc/InSinhal.pl -lib/gc_sc/InSmallF.pl -lib/gc_sc/InSpacin.pl -lib/gc_sc/InSpecia.pl -lib/gc_sc/InSundan.pl -lib/gc_sc/InSupers.pl -lib/gc_sc/InSuppl2.pl -lib/gc_sc/InSuppl3.pl -lib/gc_sc/InSuppl4.pl -lib/gc_sc/InSuppl5.pl -lib/gc_sc/InSuppl6.pl -lib/gc_sc/InSupple.pl -lib/gc_sc/InSyloti.pl -lib/gc_sc/InSyriac.pl -lib/gc_sc/InTagalo.pl -lib/gc_sc/InTagban.pl -lib/gc_sc/InTags.pl -lib/gc_sc/InTaiLe.pl -lib/gc_sc/InTaiXua.pl -lib/gc_sc/InTamil.pl -lib/gc_sc/InTelugu.pl -lib/gc_sc/InThaana.pl -lib/gc_sc/InThai.pl -lib/gc_sc/InTibeta.pl -lib/gc_sc/InTifina.pl -lib/gc_sc/InUgarit.pl -lib/gc_sc/InUnifie.pl -lib/gc_sc/InVai.pl -lib/gc_sc/InVaria2.pl -lib/gc_sc/InVariat.pl -lib/gc_sc/InVertic.pl -lib/gc_sc/InYiRadi.pl -lib/gc_sc/InYiSyll.pl -lib/gc_sc/InYijing.pl -lib/gc_sc/JoinC.pl -lib/gc_sc/JoinCont.pl -lib/gc_sc/Kana.pl -lib/gc_sc/KayahLi.pl -lib/gc_sc/Khar.pl -lib/gc_sc/Khmr.pl -lib/gc_sc/Knda.pl -lib/gc_sc/L.pl -lib/gc_sc/LC.pl -lib/gc_sc/LOE.pl -lib/gc_sc/Laoo.pl -lib/gc_sc/Latn.pl -lib/gc_sc/Lepc.pl -lib/gc_sc/Limb.pl -lib/gc_sc/LinearB.pl -lib/gc_sc/Ll.pl -lib/gc_sc/Lm.pl -lib/gc_sc/Lo.pl -lib/gc_sc/LogicalO.pl -lib/gc_sc/Lower.pl -lib/gc_sc/Lowercas.pl -lib/gc_sc/Lt.pl -lib/gc_sc/Lu.pl -lib/gc_sc/Lyci.pl -lib/gc_sc/Lydi.pl -lib/gc_sc/M.pl -lib/gc_sc/Math.pl -lib/gc_sc/Mc.pl -lib/gc_sc/Me.pl -lib/gc_sc/Mlym.pl -lib/gc_sc/Mn.pl -lib/gc_sc/Mong.pl -lib/gc_sc/Mymr.pl -lib/gc_sc/N.pl -lib/gc_sc/NChar.pl -lib/gc_sc/Nd.pl -lib/gc_sc/NewTaiLu.pl -lib/gc_sc/Nkoo.pl -lib/gc_sc/Nl.pl -lib/gc_sc/No.pl -lib/gc_sc/Nonchara.pl -lib/gc_sc/OAlpha.pl -lib/gc_sc/ODI.pl -lib/gc_sc/OGrExt.pl -lib/gc_sc/OIDC.pl -lib/gc_sc/OIDS.pl -lib/gc_sc/OLower.pl -lib/gc_sc/OMath.pl -lib/gc_sc/OUpper.pl -lib/gc_sc/Ogam.pl -lib/gc_sc/OlChiki.pl -lib/gc_sc/OldItali.pl -lib/gc_sc/OldPersi.pl -lib/gc_sc/Orya.pl -lib/gc_sc/Osma.pl -lib/gc_sc/OtherAlp.pl -lib/gc_sc/OtherDef.pl -lib/gc_sc/OtherGra.pl -lib/gc_sc/OtherIdC.pl -lib/gc_sc/OtherIdS.pl -lib/gc_sc/OtherLow.pl -lib/gc_sc/OtherMat.pl -lib/gc_sc/OtherUpp.pl -lib/gc_sc/P.pl -lib/gc_sc/PatSyn.pl -lib/gc_sc/PatWS.pl -lib/gc_sc/PatternS.pl -lib/gc_sc/PatternW.pl -lib/gc_sc/Pc.pl -lib/gc_sc/Pd.pl -lib/gc_sc/Pe.pl -lib/gc_sc/PerlSpac.pl -lib/gc_sc/PerlWord.pl -lib/gc_sc/Pf.pl -lib/gc_sc/PhagsPa.pl -lib/gc_sc/Phnx.pl -lib/gc_sc/Pi.pl -lib/gc_sc/Po.pl -lib/gc_sc/PosixAln.pl -lib/gc_sc/PosixAlp.pl -lib/gc_sc/PosixBla.pl -lib/gc_sc/PosixCnt.pl -lib/gc_sc/PosixDig.pl -lib/gc_sc/PosixGra.pl -lib/gc_sc/PosixLow.pl -lib/gc_sc/PosixPri.pl -lib/gc_sc/PosixPun.pl -lib/gc_sc/PosixSpa.pl -lib/gc_sc/PosixUpp.pl -lib/gc_sc/Print.pl -lib/gc_sc/Ps.pl -lib/gc_sc/Punct.pl -lib/gc_sc/QMark.pl -lib/gc_sc/Qaai.pl -lib/gc_sc/Quotatio.pl -lib/gc_sc/Radical.pl -lib/gc_sc/Radical2.pl -lib/gc_sc/Rjng.pl -lib/gc_sc/Runr.pl -lib/gc_sc/S.pl -lib/gc_sc/SD.pl -lib/gc_sc/STerm.pl -lib/gc_sc/Saur.pl -lib/gc_sc/Sc.pl -lib/gc_sc/Shaw.pl -lib/gc_sc/Sinh.pl -lib/gc_sc/Sk.pl -lib/gc_sc/Sm.pl -lib/gc_sc/So.pl -lib/gc_sc/SoftDott.pl -lib/gc_sc/Space.pl -lib/gc_sc/SpacePer.pl -lib/gc_sc/Sterm2.pl -lib/gc_sc/Sund.pl -lib/gc_sc/SylotiNa.pl -lib/gc_sc/Syrc.pl -lib/gc_sc/Tagb.pl -lib/gc_sc/TaiLe.pl -lib/gc_sc/Taml.pl -lib/gc_sc/Telu.pl -lib/gc_sc/Term.pl -lib/gc_sc/Terminal.pl -lib/gc_sc/Tfng.pl -lib/gc_sc/Tglg.pl -lib/gc_sc/Thaa.pl -lib/gc_sc/Thai.pl -lib/gc_sc/Tibt.pl -lib/gc_sc/Title.pl -lib/gc_sc/UIdeo.pl -lib/gc_sc/Ugar.pl -lib/gc_sc/UnifiedI.pl -lib/gc_sc/Upper.pl -lib/gc_sc/Uppercas.pl -lib/gc_sc/VS.pl -lib/gc_sc/Vaii.pl -lib/gc_sc/Variatio.pl -lib/gc_sc/VertSpac.pl -lib/gc_sc/WSpace.pl -lib/gc_sc/WhiteSpa.pl -lib/gc_sc/Word.pl -lib/gc_sc/XDigit.pl -lib/gc_sc/Xsux.pl -lib/gc_sc/Yiii.pl -lib/gc_sc/Z.pl -lib/gc_sc/Zl.pl -lib/gc_sc/Zp.pl -lib/gc_sc/Zs.pl -lib/gc_sc/Zyyy.pl -lib/gc_sc/_CanonDC.pl -lib/gc_sc/_CaseIgn.pl -lib/gc_sc/_CombAbo.pl -lib/hst/L.pl -lib/hst/LV.pl -lib/hst/LVT.pl -lib/hst/T.pl -lib/hst/V.pl -lib/jt/C.pl -lib/jt/D.pl -lib/jt/R.pl -lib/jt/U.pl -lib/lb/AI.pl -lib/lb/AL.pl -lib/lb/B2.pl -lib/lb/BA.pl -lib/lb/BB.pl -lib/lb/BK.pl -lib/lb/CB.pl -lib/lb/CL.pl -lib/lb/CM.pl -lib/lb/CR.pl -lib/lb/EX.pl -lib/lb/GL.pl -lib/lb/H2.pl -lib/lb/H3.pl -lib/lb/HY.pl -lib/lb/ID.pl -lib/lb/IN.pl -lib/lb/IS.pl -lib/lb/JL.pl -lib/lb/JT.pl -lib/lb/JV.pl -lib/lb/LF.pl -lib/lb/NL.pl -lib/lb/NS.pl -lib/lb/NU.pl -lib/lb/OP.pl -lib/lb/PO.pl -lib/lb/PR.pl -lib/lb/QU.pl -lib/lb/SA.pl -lib/lb/SG.pl -lib/lb/SP.pl -lib/lb/SY.pl -lib/lb/WJ.pl -lib/lb/XX.pl -lib/lb/ZW.pl -lib/nt/De.pl -lib/nt/Di.pl -lib/nt/Nu.pl - -# 24 input files -# 514 output files - -# End list diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl index 41a0662fd8..250eb69f05 100644 --- a/lib/utf8_heavy.pl +++ b/lib/utf8_heavy.pl @@ -8,8 +8,6 @@ sub DESTROY {} my %Cache; -our (%PropertyAlias, %PA_reverse, %PropValueAlias, %PVA_reverse, %PVA_abbr_map); - sub croak { require Carp; Carp::croak(@_) } ## @@ -17,272 +15,450 @@ sub croak { require Carp; Carp::croak(@_) } ## It's a data structure that encodes a set of Unicode characters. ## -sub SWASHNEW { - my ($class, $type, $list, $minbits, $none) = @_; - local $^D = 0 if $^D; - - print STDERR "SWASHNEW @_\n" if DEBUG; - - ## - ## Get the list of codepoints for the type. - ## Called from swash_init (see utf8.c) or SWASHNEW itself. - ## - ## Callers of swash_init: - ## op.c:pmtrans -- for tr/// and y/// - ## regexec.c:regclass_swash -- for /[]/, \p, and \P - ## utf8.c:is_utf8_common -- for common Unicode properties - ## utf8.c:to_utf8_case -- for lc, uc, ucfirst, etc. and //i - ## - ## Given a $type, our goal is to fill $list with the set of codepoint - ## ranges. If $type is false, $list passed is used. - ## - ## $minbits: - ## For binary properties, $minbits must be 1. - ## For character mappings (case and transliteration), $minbits must - ## be a number except 1. - ## - ## $list (or that filled according to $type): - ## Refer to perlunicode.pod, "User-Defined Character Properties." - ## - ## For binary properties, only characters with the property value - ## of True should be listed. The 3rd column, if any, will be ignored. - ## - ## To make the parsing of $type clear, this code takes the a rather - ## unorthodox approach of last'ing out of the block once we have the - ## info we need. Were this to be a subroutine, the 'last' would just - ## be a 'return'. - ## - my $file; ## file to load data from, and also part of the %Cache key. - my $ListSorted = 0; - - if ($type) - { - $type =~ s/^\s+//; - $type =~ s/\s+$//; - - print STDERR "type = $type\n" if DEBUG; - - GETFILE: +{ + # If a floating point number is within this distance from the value of a + # fraction, it is considered to be that fraction, even if many more digits + # are specified that don't exactly match. + my $min_floating_slop; + + sub SWASHNEW { + my ($class, $type, $list, $minbits, $none) = @_; + local $^D = 0 if $^D; + + print STDERR __LINE__, ": ", join(", ", @_), "\n" if DEBUG; + + ## + ## Get the list of codepoints for the type. + ## Called from swash_init (see utf8.c) or SWASHNEW itself. + ## + ## Callers of swash_init: + ## op.c:pmtrans -- for tr/// and y/// + ## regexec.c:regclass_swash -- for /[]/, \p, and \P + ## utf8.c:is_utf8_common -- for common Unicode properties + ## utf8.c:to_utf8_case -- for lc, uc, ucfirst, etc. and //i + ## + ## Given a $type, our goal is to fill $list with the set of codepoint + ## ranges. If $type is false, $list passed is used. + ## + ## $minbits: + ## For binary properties, $minbits must be 1. + ## For character mappings (case and transliteration), $minbits must + ## be a number except 1. + ## + ## $list (or that filled according to $type): + ## Refer to perlunicode.pod, "User-Defined Character Properties." + ## + ## For binary properties, only characters with the property value + ## of True should be listed. The 3rd column, if any, will be ignored + ## + ## $none is undocumented, so I'm (khw) trying to do some documentation + ## of it now. It appears to be if there is a mapping in an input file + ## that maps to 'XXXX', then that is replaced by $none+1, expressed in + ## hexadecimal. The only place I found it possibly used was in + ## S_pmtrans in op.c. + ## + ## To make the parsing of $type clear, this code takes the a rather + ## unorthodox approach of last'ing out of the block once we have the + ## info we need. Were this to be a subroutine, the 'last' would just + ## be a 'return'. + ## + my $file; ## file to load data from, and also part of the %Cache key. + my $ListSorted = 0; + + # Change this to get a different set of Unicode tables + my $unicore_dir = 'unicore'; + + if ($type) { - ## - ## It could be a user-defined property. - ## - - my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1); - - if (defined $caller1 && $type =~ /^(?:\w+)$/) { - my $prop = "${caller1}::$type"; - if (exists &{$prop}) { - no strict 'refs'; - - $list = &{$prop}; - last GETFILE; - } - } - - my $wasIs; - - ($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i) - or - $type =~ s/^(?:(?:General(?:\s+|_)?)?Category|gc)\s*[:=]\s*//i - or - $type =~ s/^(?:Script|sc)\s*[:=]\s*//i - or - $type =~ s/^Block\s*[:=]\s*/In/i; - - - ## - ## See if it's in some enumeration. - ## - require "unicore/PVA.pl"; - if ($type =~ /^([\w\s]+)[:=]\s*(.*)/) { - my ($enum, $val) = (lc $1, lc $2); - $enum =~ tr/ _-//d; - $val =~ tr/ _-//d; - - my $pa = $PropertyAlias{$enum} ? $enum : $PA_reverse{$enum}; - my $f = $PropValueAlias{$pa}{$val} ? $val : $PVA_reverse{$pa}{lc $val}; - - if ($pa and $f) { - $pa = "gc_sc" if $pa eq "gc" or $pa eq "sc"; - $file = "unicore/lib/$pa/$PVA_abbr_map{$pa}{lc $f}.pl"; - last GETFILE; - } - } - else { - my $t = lc $type; - $t =~ tr/ _-//d; - - if ($PropValueAlias{gc}{$t} or $PropValueAlias{sc}{$t}) { - $file = "unicore/lib/gc_sc/$PVA_abbr_map{gc_sc}{$t}.pl"; - last GETFILE; - } - } - - ## - ## See if it's in the direct mapping table. - ## - require "unicore/Exact.pl"; - if (my $base = $utf8::Exact{$type}) { - $file = "unicore/lib/gc_sc/$base.pl"; - last GETFILE; + $type =~ s/^\s+//; + $type =~ s/\s+$//; + + print STDERR __LINE__, ": type = $type\n" if DEBUG; + + GETFILE: + { + ## + ## It could be a user-defined property. + ## + + my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1); + + if (defined $caller1 && $type =~ /^(?:\w+)$/) { + my $prop = "${caller1}::$type"; + if (exists &{$prop}) { + no strict 'refs'; + + $list = &{$prop}; + last GETFILE; + } + } + + require "$unicore_dir/Heavy.pl"; + + # Everything is caseless matching + my $property_and_table = lc $type; + print STDERR __LINE__, ": $property_and_table\n" if DEBUG; + + # See if is of the compound form 'property=value', where the + # value indicates the table we should use. + my ($property, $table, @remainder) = + split /\s*[:=]\s*/, $property_and_table, -1; + return $type if @remainder; + + my $prefix; + if (! defined $table) { + + # Here, is the single form. The property becomes empty, and + # the whole value is the table. + $table = $property; + $prefix = $property = ""; + } else { + print STDERR __LINE__, ": $property\n" if DEBUG; + + # Here it is the compound property=table form. The property + # name is always loosely matched, which means remove any of + # these: + $property =~ s/[_\s-]//g; + + # And convert to canonical form. Quit if not valid. + $property = $utf8::loose_property_name_of{$property}; + return $type unless defined $property; + + $prefix = "$property="; + + # If the rhs looks like it is a number... + print STDERR __LINE__, ": table=$table\n" if DEBUG; + if ($table =~ qr{ ^ [ \s 0-9 _ + / . -]+ $ }x) { + print STDERR __LINE__, ": table=$table\n" if DEBUG; + + # Don't allow leading nor trailing slashes + return $type if $table =~ / ^ \/ | \/ $ /x; + + # Split on slash, in case it is a rational, like \p{1/5} + my @parts = split qr{ \s* / \s* }x, $table, -1; + print __LINE__, ": $type\n" if @parts > 2 && DEBUG; + + # Can have maximum of one slash + return $type if @parts > 2; + + foreach my $part (@parts) { + print __LINE__, ": part=$part\n" if DEBUG; + + $part =~ s/^\+\s*//; # Remove leading plus + $part =~ s/^-\s*/-/; # Remove blanks after unary + # minus + + # Remove underscores between digits. + $part =~ s/( ?<= [0-9] ) _ (?= [0-9] ) //xg; + + # No leading zeros (but don't make a single '0' + # into a null string) + $part =~ s/ ^ ( -? ) 0+ /$1/x; + $part .= '0' if $part eq '-' || $part eq ""; + + # No trailing zeros after a decimal point + $part =~ s/ ( \. .*? ) 0+ $ /$1/x; + + # Begin with a 0 if a leading decimal point + $part =~ s/ ^ ( -? ) \. /${1}0./x; + + # Ensure not a trailing decimal point: turn into an + # integer + $part =~ s/ \. $ //x; + + print STDERR __LINE__, ": part=$part\n" if DEBUG; + #return $type if $part eq ""; + + # Result better look like a number. (This test is + # needed because, for example could have a plus in + # the middle.) + return $type if $part + !~ / ^ -? [0-9]+ ( \. [0-9]+)? $ /x; + } + + # If a rational... + if (@parts == 2) { + + # If denominator is negative, get rid of it, and ... + if ($parts[1] =~ s/^-//) { + + # If numerator is also negative, convert the + # whole thing to positive, or move the minus to + # the numerator + if ($parts[0] !~ s/^-//) { + $parts[0] = '-' . $parts[0]; + } + } + $table = join '/', @parts; + } + elsif ($property ne 'nv' || $parts[0] !~ /\./) { + + # Here is not numeric value, or doesn't have a + # decimal point. No further manipulation is + # necessary. (Note the hard-coded property name. + # This could fail if other properties eventually + # had fractions as well; perhaps the cjk ones + # could evolve to do that. This hard-coding could + # be fixed by mktables generating a list of + # properties that could have fractions.) + $table = $parts[0]; + } else { + + # Here is a floating point numeric_value. Try to + # convert to rational. First see if is in the list + # of known ones. + if (exists $utf8::nv_floating_to_rational{$parts[0]}) { + $table = $utf8::nv_floating_to_rational{$parts[0]}; + } else { + + # Here not in the list. See if is close + # enough to something in the list. First + # determine what 'close enough' means. It has + # to be as tight as what mktables says is the + # maximum slop, and as tight as how many + # digits we were passed. That is, if the user + # said .667, .6667, .66667, etc. we match as + # many digits as they passed until get to + # where it doesn't matter any more due to the + # machine's precision. If they said .6666668, + # we fail. + (my $fraction = $parts[0]) =~ s/^.*\.//; + my $epsilon = 10 ** - (length($fraction)); + if ($epsilon > $utf8::max_floating_slop) { + $epsilon = $utf8::max_floating_slop; + } + + # But it can't be tighter than the minimum + # precision for this machine. If haven't + # already calculated that minimum, do so now. + if (! defined $min_floating_slop) { + + # Keep going down an order of magnitude + # until find that adding this quantity to + # 1 remains 1; but put an upper limit on + # this so in case this algorithm doesn't + # work properly on some platform, that we + # won't loop forever. + my $count = 0; + $min_floating_slop = 1; + while (1+ $min_floating_slop != 1 + && $count++ < 50) + { + my $next = $min_floating_slop / 10; + last if $next == 0; # If underflows, + # use previous one + $min_floating_slop = $next; + print STDERR __LINE__, ": min_float_slop=$min_floating_slop\n" if DEBUG; + } + + # Back off a couple orders of magnitude, + # just to be safe. + $min_floating_slop *= 100; + } + + if ($epsilon < $min_floating_slop) { + $epsilon = $min_floating_slop; + } + print STDERR __LINE__, ": fraction=.$fraction; epsilon=$epsilon\n" if DEBUG; + + undef $table; + + # And for each possible rational in the table, + # see if it is within epsilon of the input. + foreach my $official + (keys %utf8::nv_floating_to_rational) + { + print STDERR __LINE__, ": epsilon=$epsilon, official=$official, diff=", abs($parts[0] - $official), "\n" if DEBUG; + if (abs($parts[0] - $official) < $epsilon) { + $table = + $utf8::nv_floating_to_rational{$official}; + last; + } + } + + # Quit if didn't find one. + return $type unless defined $table; + } + } + print STDERR __LINE__, ": $property=$table\n" if DEBUG; + } + } + + # Combine lhs (if any) and rhs to get something that matches + # the syntax of the lookups. + $property_and_table = "$prefix$table"; + print STDERR __LINE__, ": $property_and_table\n" if DEBUG; + + # First try stricter matching. + $file = $utf8::stricter_to_file_of{$property_and_table}; + + # If didn't find it, try again with looser matching by editing + # out the applicable characters on the rhs and looking up + # again. + if (! defined $file) { + $table =~ s/ [_\s-] //xg; + $property_and_table = "$prefix$table"; + print STDERR __LINE__, ": $property_and_table\n" if DEBUG; + $file = $utf8::loose_to_file_of{$property_and_table}; + } + + # Add the constant and go fetch it in. + if (defined $file) { + if ($utf8::why_deprecated{$file}) { + warnings::warnif('deprecated', "Use of '$type' in \\p{} or \\P{} is deprecated because: $utf8::why_deprecated{$file};"); + } + $file= "$unicore_dir/lib/$file.pl"; + last GETFILE; + } + print STDERR __LINE__, ": didn't find $property_and_table\n" if DEBUG; + + ## + ## See if it's a user-level "To". + ## + + my $caller0 = caller(0); + + if (defined $caller0 && $type =~ /^To(?:\w+)$/) { + my $map = $caller0 . "::" . $type; + + if (exists &{$map}) { + no strict 'refs'; + + $list = &{$map}; + last GETFILE; + } + } + + ## + ## Last attempt -- see if it's a standard "To" name + ## (e.g. "ToLower") ToTitle is used by ucfirst(). + ## The user-level way to access ToDigit() and ToFold() + ## is to use Unicode::UCD. + ## + if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/) { + $file = "$unicore_dir/To/$1.pl"; + ## would like to test to see if $file actually exists.... + last GETFILE; + } + + ## + ## If we reach this line, it's because we couldn't figure + ## out what to do with $type. Ouch. + ## + + return $type; } - ## - ## If not there exactly, try the canonical form. The canonical - ## form is lowercased, with any separators (\s+|[-_]) removed. - ## - my $canonical = lc $type; - $canonical =~ s/(?<=[a-z\d])(?:\s+|[-_])(?=[a-z\d])//g; - print STDERR "canonical = $canonical\n" if DEBUG; - - require "unicore/Canonical.pl"; - { no warnings "uninitialized"; - if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) { - $file = "unicore/lib/gc_sc/$base.pl"; - last GETFILE; - } + if (defined $file) { + print STDERR __LINE__, ": found it (file='$file')\n" if DEBUG; + + ## + ## If we reach here, it was due to a 'last GETFILE' above + ## (exception: user-defined properties and mappings), so we + ## have a filename, so now we load it if we haven't already. + ## If we have, return the cached results. The cache key is the + ## class and file to load. + ## + my $found = $Cache{$class, $file}; + if ($found and ref($found) eq $class) { + print STDERR __LINE__, ": Returning cached '$file' for \\p{$type}\n" if DEBUG; + return $found; + } + + local $@; + local $!; + $list = do $file; die $@ if $@; } - ## - ## See if it's a user-level "To". - ## - - my $caller0 = caller(0); - - if (defined $caller0 && $type =~ /^To(?:\w+)$/) { - my $map = $caller0 . "::" . $type; - - if (exists &{$map}) { - no strict 'refs'; - - $list = &{$map}; - last GETFILE; - } - } - - ## - ## Last attempt -- see if it's a standard "To" name - ## (e.g. "ToLower") ToTitle is used by ucfirst(). - ## The user-level way to access ToDigit() and ToFold() - ## is to use Unicode::UCD. - ## - if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/) { - $file = "unicore/To/$1.pl"; - ## would like to test to see if $file actually exists.... - last GETFILE; - } - - ## - ## If we reach this line, it's because we couldn't figure - ## out what to do with $type. Ouch. - ## - - return $type; + $ListSorted = 1; ## we know that these lists are sorted } - if (defined $file) { - print STDERR "found it (file='$file')\n" if DEBUG; - - ## - ## If we reach here, it was due to a 'last GETFILE' above - ## (exception: user-defined properties and mappings), so we - ## have a filename, so now we load it if we haven't already. - ## If we have, return the cached results. The cache key is the - ## class and file to load. - ## - my $found = $Cache{$class, $file}; - if ($found and ref($found) eq $class) { - print STDERR "Returning cached '$file' for \\p{$type}\n" if DEBUG; - return $found; - } - - local $@; - local $!; - $list = do $file; die $@ if $@; - } - - $ListSorted = 1; ## we know that these lists are sorted - } - - my $extras; - my $bits = $minbits; - - my $ORIG = $list; - if ($list) { - my @tmp = split(/^/m, $list); - my %seen; - no warnings; - $extras = join '', grep /^[^0-9a-fA-F]/, @tmp; - $list = join '', - map { $_->[1] } - sort { $a->[0] <=> $b->[0] } - map { /^([0-9a-fA-F]+)/; [ CORE::hex($1), $_ ] } - grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right - } + my $extras; + my $bits = $minbits; + + my $ORIG = $list; + if ($list) { + my @tmp = split(/^/m, $list); + my %seen; + no warnings; + $extras = join '', grep /^[^0-9a-fA-F]/, @tmp; + $list = join '', + map { $_->[1] } + sort { $a->[0] <=> $b->[0] } + map { /^([0-9a-fA-F]+)/; [ CORE::hex($1), $_ ] } + grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right + } - if ($none) { - my $hextra = sprintf "%04x", $none + 1; - $list =~ s/\tXXXX$/\t$hextra/mg; - } + if ($none) { + my $hextra = sprintf "%04x", $none + 1; + $list =~ s/\tXXXX$/\t$hextra/mg; + } - if ($minbits != 1 && $minbits < 32) { # not binary property - my $top = 0; - while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) { - my $min = CORE::hex $1; - my $max = defined $2 ? CORE::hex $2 : $min; - my $val = defined $3 ? CORE::hex $3 : 0; - $val += $max - $min if defined $3; - $top = $val if $val > $top; - } - my $topbits = - $top > 0xffff ? 32 : - $top > 0xff ? 16 : 8; - $bits = $topbits if $bits < $topbits; - } + if ($minbits != 1 && $minbits < 32) { # not binary property + my $top = 0; + while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) { + my $min = CORE::hex $1; + my $max = defined $2 ? CORE::hex $2 : $min; + my $val = defined $3 ? CORE::hex $3 : 0; + $val += $max - $min if defined $3; + $top = $val if $val > $top; + } + my $topbits = + $top > 0xffff ? 32 : + $top > 0xff ? 16 : 8; + $bits = $topbits if $bits < $topbits; + } - my @extras; - for my $x ($extras) { - pos $x = 0; - while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) { - my $char = $1; - my $name = $2; - print STDERR "$1 => $2\n" if DEBUG; - if ($char =~ /[-+!&]/) { - my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really - my $subobj; - if ($c eq 'utf8') { - $subobj = utf8->SWASHNEW($t, "", $minbits, 0); - } - elsif (exists &$name) { - $subobj = utf8->SWASHNEW($name, "", $minbits, 0); - } - elsif ($c =~ /^([0-9a-fA-F]+)/) { - $subobj = utf8->SWASHNEW("", $c, $minbits, 0); - } - return $subobj unless ref $subobj; - push @extras, $name => $subobj; - $bits = $subobj->{BITS} if $bits < $subobj->{BITS}; - } - } - } + my @extras; + if ($extras) { + for my $x ($extras) { + pos $x = 0; + while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) { + my $char = $1; + my $name = $2; + print STDERR __LINE__, ": $1 => $2\n" if DEBUG; + if ($char =~ /[-+!&]/) { + my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really + my $subobj; + if ($c eq 'utf8') { + $subobj = utf8->SWASHNEW($t, "", $minbits, 0); + } + elsif (exists &$name) { + $subobj = utf8->SWASHNEW($name, "", $minbits, 0); + } + elsif ($c =~ /^([0-9a-fA-F]+)/) { + $subobj = utf8->SWASHNEW("", $c, $minbits, 0); + } + return $subobj unless ref $subobj; + push @extras, $name => $subobj; + $bits = $subobj->{BITS} if $bits < $subobj->{BITS}; + } + } + } + } - print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG; + if (DEBUG) { + print STDERR __LINE__, ": CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none"; + print STDERR "\nLIST =>\n$list" if defined $list; + print STDERR "\nEXTRAS =>\n$extras" if defined $extras; + print STDERR "\n"; + } - my $SWASH = bless { - TYPE => $type, - BITS => $bits, - EXTRAS => $extras, - LIST => $list, - NONE => $none, - @extras, - } => $class; + my $SWASH = bless { + TYPE => $type, + BITS => $bits, + EXTRAS => $extras, + LIST => $list, + NONE => $none, + @extras, + } => $class; + + if ($file) { + $Cache{$class, $file} = $SWASH; + } - if ($file) { - $Cache{$class, $file} = $SWASH; + return $SWASH; } - - return $SWASH; } # Now SWASHGET is recasted into a C function S_swash_get (see utf8.c). diff --git a/lib/version/Internals.pod b/lib/version/Internals.pod index 42dde75f64..597b46555e 100644 --- a/lib/version/Internals.pod +++ b/lib/version/Internals.pod @@ -222,7 +222,7 @@ For example: IMPORTANT NOTE: This may mean that code which searches for a specific string (to determine whether a given module is available) may need to be changed. It is always better to use the built-in comparison implicit in -C<use> or C<require>, rather than manually poking at C<class->VERSION> +C<use> or C<require>, rather than manually poking at C<< class->VERSION >> and then doing a comparison yourself. The replacement UNIVERSAL::VERSION, when used as a function, like this: diff --git a/lib/warnings.pm b/lib/warnings.pm index 6049437d63..771c98cba8 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -6,7 +6,7 @@ package warnings; -our $VERSION = '1.07'; +our $VERSION = '1.08'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -84,6 +84,27 @@ Return TRUE if that warnings category is enabled in the first scope where the object is used. Otherwise returns FALSE. +=item warnings::fatal_enabled() + +Return TRUE if the warnings category with the same name as the current +package has been set to FATAL in the calling module. +Otherwise returns FALSE. + +=item warnings::fatal_enabled($category) + +Return TRUE if the warnings category C<$category> has been set to FATAL in +the calling module. +Otherwise returns FALSE. + +=item warnings::fatal_enabled($object) + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +Return TRUE if that warnings category has been set to FATAL in the first +scope where the object is used. +Otherwise returns FALSE. + =item warnings::warn($message) Print C<$message> to STDERR. @@ -469,6 +490,17 @@ sub enabled vec($callers_bitmask, $Offsets{'all'}, 1) ; } +sub fatal_enabled +{ + Croaker("Usage: warnings::fatal_enabled([category])") + unless @_ == 1 || @_ == 0 ; + + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return 0 unless defined $callers_bitmask; + return vec($callers_bitmask, $offset + 1, 1) || + vec($callers_bitmask, $Offsets{'all'} + 1, 1) ; +} sub warn { diff --git a/makedef.pl b/makedef.pl index 9e261e5318..cef774e39c 100644 --- a/makedef.pl +++ b/makedef.pl @@ -632,6 +632,7 @@ unless ($define{'DEBUGGING'}) { Perl_pad_sv Perl_hv_assert PL_block_type + PL_scopestack_name PL_watchaddr PL_watchok PL_watch_pvx @@ -684,11 +684,13 @@ Perl_init_i18nl14n(pTHX_ int printwarn) PP(pp_padany) { DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); + return NORMAL; } PP(pp_mapstart) { DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ + return NORMAL; } /* These ops all have the same body as pp_null. */ @@ -1525,8 +1525,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if(i) LEAVE; #endif - if(to_dec) - SvREFCNT_dec(to_dec); + SvREFCNT_dec(to_dec); return 0; } #endif /* !PERL_MICRO */ @@ -2357,8 +2356,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif } else if (strEQ(mg->mg_ptr+1, "NCODING")) { - if (PL_encoding) - SvREFCNT_dec(PL_encoding); + SvREFCNT_dec(PL_encoding); if (SvOK(sv) || SvGMAGICAL(sv)) { PL_encoding = newSVsv(sv); } @@ -2537,8 +2535,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_rs = newSVsv(sv); break; case '\\': - if (PL_ors_sv) - SvREFCNT_dec(PL_ors_sv); + SvREFCNT_dec(PL_ors_sv); if (SvOK(sv) || SvGMAGICAL(sv)) { PL_ors_sv = newSVsv(sv); } @@ -1,3 +1,4 @@ +#line 2 "op.c" /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, @@ -371,7 +372,7 @@ S_no_bareword_allowed(pTHX_ const OP *o) /* "register" allocation */ PADOFFSET -Perl_allocmy(pTHX_ const char *const name) +Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { dVAR; PADOFFSET off; @@ -379,38 +380,43 @@ Perl_allocmy(pTHX_ const char *const name) PERL_ARGS_ASSERT_ALLOCMY; + if (flags) + Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, + (UV)flags); + + /* Until we're using the length for real, cross check that we're being + told the truth. */ + assert(strlen(name) == len); + /* complain about "my $<special_var>" etc etc */ - if (*name && + if (len && !(is_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || - (name[1] == '_' && (*name == '$' || name[2])))) + (name[1] == '_' && (*name == '$' || len > 2)))) { /* name[2] is true if strlen(name) > 2 */ if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { - yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"", - name[0], toCTRL(name[1]), name + 2, + yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", + name[0], toCTRL(name[1]), (int)(len - 2), name + 2, PL_parser->in_my == KEY_state ? "state" : "my")); } else { - yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name, + yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, PL_parser->in_my == KEY_state ? "state" : "my")); } } - /* check for duplicate declaration */ - pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash)); - /* allocate a spare slot and store the name in that slot */ - off = pad_add_name(name, + off = pad_add_name(name, len, + is_our ? padadd_OUR : + PL_parser->in_my == KEY_state ? padadd_STATE : 0, PL_parser->in_my_stash, (is_our /* $_ is always in main::, even with our */ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : NULL - ), - 0, /* not fake */ - PL_parser->in_my == KEY_state + ) ); /* anon sub prototypes contains state vars should always be cloned, * otherwise the state var would be shared between anon subs */ @@ -569,6 +575,29 @@ Perl_op_clear(pTHX_ OP *o) case OP_AELEMFAST: if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { /* not an OP_PADAV replacement */ + GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV) +#ifdef USE_ITHREADS + && PL_curpad +#endif + ? cGVOPo_gv : NULL; + /* It's possible during global destruction that the GV is freed + before the optree. Whilst the SvREFCNT_inc is happy to bump from + 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0 + will trigger an assertion failure, because the entry to sv_clear + checks that the scalar is not already freed. A check of for + !SvIS_FREED(gv) turns out to be invalid, because during global + destruction the reference count can be forced down to zero + (with SVf_BREAK set). In which case raising to 1 and then + dropping to 0 triggers cleanup before it should happen. I + *think* that this might actually be a general, systematic, + weakness of the whole idea of SVf_BREAK, in that code *is* + allowed to raise and lower references during global destruction, + so any *valid* code that happens to do this during global + destruction might well trigger premature cleanup. */ + bool still_valid = gv && SvREFCNT(gv); + + if (still_valid) + SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { /* No GvIN_PAD_off(cGVOPo_gv) here, because other references @@ -580,6 +609,12 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; #endif + if (still_valid) { + int try_downgrade = SvREFCNT(gv) == 2; + SvREFCNT_dec(gv); + if (try_downgrade) + gv_try_downgrade(gv); + } } break; case OP_METHOD_NAMED: @@ -950,7 +985,7 @@ Perl_scalarvoid(pTHX_ OP *o) want = o->op_flags & OPf_WANT; if ((want && want != OPf_WANT_SCALAR) || (PL_parser && PL_parser->error_count) - || o->op_type == OP_RETURN) + || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE) { return o; } @@ -1180,10 +1215,6 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_ENTEREVAL: scalarkids(o); break; - case OP_REQUIRE: - /* all requires must return a boolean value */ - o->op_flags &= ~OPf_WANT; - /* FALL THROUGH */ case OP_SCALAR: return scalar(o); } @@ -1272,10 +1303,6 @@ Perl_list(pTHX_ OP *o) } PL_curcop = &PL_compiling; break; - case OP_REQUIRE: - /* all requires must return a boolean value */ - o->op_flags &= ~OPf_WANT; - return scalar(o); } return o; } @@ -2280,7 +2307,7 @@ STATIC OP * S_newDEFSVOP(pTHX) { dVAR; - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } @@ -2985,6 +3012,8 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) dVAR; LISTOP *listop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP); + NewOp(1101, listop, 1, LISTOP); listop->op_type = (OPCODE)type; @@ -3018,6 +3047,12 @@ Perl_newOP(pTHX_ I32 type, I32 flags) { dVAR; OP *o; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + NewOp(1101, o, 1, OP); o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; @@ -3041,6 +3076,13 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) dVAR; UNOP *unop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP + || type == OP_SASSIGN + || type == OP_NULL ); + if (!first) first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) @@ -3064,6 +3106,10 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { dVAR; BINOP *binop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP + || type == OP_SASSIGN || type == OP_NULL ); + NewOp(1101, binop, 1, BINOP); if (!first) @@ -3459,6 +3505,8 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) dVAR; PMOP *pmop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP); + NewOp(1101, pmop, 1, PMOP); pmop->op_type = (OPCODE)type; pmop->op_ppaddr = PL_ppaddr[type]; @@ -3703,6 +3751,10 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) PERL_ARGS_ASSERT_NEWSVOP; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); + NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)type; svop->op_ppaddr = PL_ppaddr[type]; @@ -3725,6 +3777,10 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) PERL_ARGS_ASSERT_NEWPADOP; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); + NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; @@ -3763,6 +3819,10 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { dVAR; PVOP *pvop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + NewOp(1101, pvop, 1, PVOP); pvop->op_type = (OPCODE)type; pvop->op_ppaddr = PL_ppaddr[type]; @@ -4520,6 +4580,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP); + scalarboolean(first); /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT @@ -4994,7 +5056,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP } } else { - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { sv = newGVOP(OP_GV, 0, PL_defgv); } @@ -5076,6 +5138,8 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) PERL_ARGS_ASSERT_NEWLOOPEX; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) @@ -5736,7 +5800,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (PL_madskills) { if (strEQ(name, "import")) { PL_formfeed = MUTABLE_SV(cv); - Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv); + /* diag_listed_as: SKIPME */ + Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv)); } } GvCVGEN(gv) = 0; @@ -7165,7 +7230,7 @@ Perl_ck_grep(pTHX_ OP *o) gwop->op_flags |= OPf_KIDS; gwop->op_other = LINKLIST(kid); kid->op_next = (OP*)gwop; - offset = pad_findmy("$_"); + offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { o->op_private = gwop->op_private = 0; gwop->op_targ = pad_alloc(type, SVs_PADTMP); @@ -7405,7 +7470,7 @@ Perl_ck_match(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_MATCH; if (o->op_type != OP_QR && PL_compcv) { - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { o->op_targ = offset; o->op_private |= OPpTARGET_MY; @@ -7604,7 +7669,7 @@ Perl_ck_require(pTHX_ OP *o) return newop; } - return ck_fun(o); + return scalar(ck_fun(o)); } OP * @@ -7944,22 +8009,29 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private |= OPpENTERSUB_HASTARG; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { - SVOP* tmpop; o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); op_null(cvop); /* disable rv2cv */ - tmpop = (SVOP*)((UNOP*)cvop)->op_first; - if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { - GV *gv = cGVOPx_gv(tmpop); - cv = GvCVu(gv); - if (!cv) - tmpop->op_private |= OPpEARLY_CV; - else { - if (SvPOK(cv)) { - STRLEN len; - namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV(MUTABLE_SV(cv), len); - proto_end = proto + len; - } + if (!(o->op_private & OPpENTERSUB_AMPER)) { + SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first; + GV *gv = NULL; + switch (tmpop->op_type) { + case OP_GV: { + gv = cGVOPx_gv(tmpop); + cv = GvCVu(gv); + if (!cv) + tmpop->op_private |= OPpEARLY_CV; + } break; + case OP_CONST: { + SV *sv = cSVOPx_sv(tmpop); + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) + cv = (CV*)SvRV(sv); + } break; + } + if (cv && SvPOK(cv)) { + STRLEN len; + namegv = gv && CvANON(cv) ? gv : CvGV(cv); + proto = SvPV(MUTABLE_SV(cv), len); + proto_end = proto + len; } } } @@ -8282,7 +8354,7 @@ Perl_ck_each(pTHX_ OP *o) /* caller is supposed to assign the return to the container of the rep_op var */ -OP * +STATIC OP * S_opt_scalarhv(pTHX_ OP *rep_op) { UNOP *unop; @@ -8307,6 +8379,78 @@ S_opt_scalarhv(pTHX_ OP *rep_op) { return (OP*)unop; } +/* Checks if o acts as an in-place operator on an array. oright points to the + * beginning of the right-hand side. Returns the left-hand side of the + * assignment if o acts in-place, or NULL otherwise. */ + +STATIC OP * +S_is_inplace_av(pTHX_ OP *o, OP *oright) { + OP *o2; + OP *oleft = NULL; + + PERL_ARGS_ASSERT_IS_INPLACE_AV; + + if (!oright || + (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) + || oright->op_next != o + || (oright->op_private & OPpLVAL_INTRO) + ) + return NULL; + + /* o2 follows the chain of op_nexts through the LHS of the + * assign (if any) to the aassign op itself */ + o2 = o->op_next; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_PUSHMARK) + return NULL; + o2 = o2->op_next; + if (o2 && o2->op_type == OP_GV) + o2 = o2->op_next; + if (!o2 + || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) + || (o2->op_private & OPpLVAL_INTRO) + ) + return NULL; + oleft = o2; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_AASSIGN + || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) + return NULL; + + /* check that the sort is the first arg on RHS of assign */ + + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_PUSHMARK) + return NULL; + if (o2->op_sibling != o) + return NULL; + + /* check the array is the same on both sides */ + if (oleft->op_type == OP_RV2AV) { + if (oright->op_type != OP_RV2AV + || !cUNOPx(oright)->op_first + || cUNOPx(oright)->op_first->op_type != OP_GV + || cGVOPx_gv(cUNOPx(oleft)->op_first) != + cGVOPx_gv(cUNOPx(oright)->op_first) + ) + return NULL; + } + else if (oright->op_type != OP_PADAV + || oright->op_targ != oleft->op_targ + ) + return NULL; + + return oleft; +} + /* A peephole optimizer. We visit the ops in the order they're to execute. * See the comments at the top of this file for more details about when * peep() is called */ @@ -8747,62 +8891,8 @@ Perl_peep(pTHX_ register OP *o) oright = cUNOPx(oright)->op_sibling; } - if (!oright || - (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) - || oright->op_next != o - || (oright->op_private & OPpLVAL_INTRO) - ) - break; - - /* o2 follows the chain of op_nexts through the LHS of the - * assign (if any) to the aassign op itself */ - o2 = o->op_next; - if (!o2 || o2->op_type != OP_NULL) - break; - o2 = o2->op_next; - if (!o2 || o2->op_type != OP_PUSHMARK) - break; - o2 = o2->op_next; - if (o2 && o2->op_type == OP_GV) - o2 = o2->op_next; - if (!o2 - || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) - || (o2->op_private & OPpLVAL_INTRO) - ) - break; - oleft = o2; - o2 = o2->op_next; - if (!o2 || o2->op_type != OP_NULL) - break; - o2 = o2->op_next; - if (!o2 || o2->op_type != OP_AASSIGN - || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) - break; - - /* check that the sort is the first arg on RHS of assign */ - - o2 = cUNOPx(o2)->op_first; - if (!o2 || o2->op_type != OP_NULL) - break; - o2 = cUNOPx(o2)->op_first; - if (!o2 || o2->op_type != OP_PUSHMARK) - break; - if (o2->op_sibling != o) - break; - - /* check the array is the same on both sides */ - if (oleft->op_type == OP_RV2AV) { - if (oright->op_type != OP_RV2AV - || !cUNOPx(oright)->op_first - || cUNOPx(oright)->op_first->op_type != OP_GV - || cGVOPx_gv(cUNOPx(oleft)->op_first) != - cGVOPx_gv(cUNOPx(oright)->op_first) - ) - break; - } - else if (oright->op_type != OP_PADAV - || oright->op_targ != oleft->op_targ - ) + oleft = is_inplace_av(o, oright); + if (!oleft) break; /* transfer MODishness etc from LHS arg to RHS arg */ @@ -8829,8 +8919,36 @@ Perl_peep(pTHX_ register OP *o) case OP_REVERSE: { OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; OP *gvop = NULL; + OP *oleft, *oright; LISTOP *enter, *exlist; + /* @a = reverse @a */ + if ((oright = cLISTOPo->op_first) + && (oright->op_type == OP_PUSHMARK) + && (oright = oright->op_sibling) + && (oleft = is_inplace_av(o, oright))) { + OP *o2; + + /* transfer MODishness etc from LHS arg to RHS arg */ + oright->op_flags = oleft->op_flags; + o->op_private |= OPpREVERSE_INPLACE; + + /* excise push->gv->rv2av->null->aassign */ + o2 = o->op_next->op_next; + op_null(o2); /* PUSHMARK */ + o2 = o2->op_next; + if (o2->op_type == OP_GV) { + op_null(o2); /* GV */ + o2 = o2->op_next; + } + op_null(o2); /* RV2AV or PADAV */ + o2 = o2->op_next->op_next; + op_null(o2); /* AASSIGN */ + + o->op_next = o2->op_next; + break; + } + enter = (LISTOP *) o->op_next; if (!enter) break; @@ -258,6 +258,9 @@ Deprecated. Use C<GIMME_V> instead. #define OPpSORT_QSORT 32 /* Use quicksort (not mergesort) */ #define OPpSORT_STABLE 64 /* Use a stable algorithm */ +/* Private for OP_REVERSE */ +#define OPpREVERSE_INPLACE 8 /* reverse in-place (@a = reverse @a) */ + /* Private for OP_OPEN and OP_BACKTICK */ #define OPpOPEN_IN_RAW 16 /* binmode(F,":raw") on input fh */ #define OPpOPEN_IN_CRLF 32 /* binmode(F,":crlf") on input fh */ diff --git a/os2/OS2/OS2-Process/Process.pm b/os2/OS2/OS2-Process/Process.pm index 37bb3f0602..494bd69bb8 100644 --- a/os2/OS2/OS2-Process/Process.pm +++ b/os2/OS2/OS2-Process/Process.pm @@ -1294,7 +1294,7 @@ is governed by $flags. Same as C<WindowPos_set>, but takes the position from keys C<fl width height x y behind hwnd> of the hash referenced by $hash. If $hwnd is explicitly -specified, it overrides C<$hash->{hwnd}>. If $hash->{flags} is not specified, +specified, it overrides C<< $hash->{hwnd} >>. If $hash->{flags} is not specified, it is calculated basing on the existing keys of $hash. Requires (morphing to) PM. Example: diff --git a/os2/OS2/OS2-REXX/DLL/DLL.pm b/os2/OS2/OS2-REXX/DLL/DLL.pm index 023c20a0bd..a0d3b21eb0 100644 --- a/os2/OS2/OS2-REXX/DLL/DLL.pm +++ b/os2/OS2/OS2-REXX/DLL/DLL.pm @@ -185,7 +185,7 @@ compatibility). Returns true if all functions are available. As a side effect, creates a REXX wrapper with the specified name in the package constructed by the name -of the DLL so that the next call to C<$dll->NAME()> will pick up the cached +of the DLL so that the next call to C<< $dll->NAME() >> will pick up the cached method. =head2 Create a Perl wrapper (optional): @@ -339,6 +339,35 @@ Perl_pad_undef(pTHX_ CV* cv) +static PADOFFSET +S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, + HV *ourstash) +{ + dVAR; + const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); + + PERL_ARGS_ASSERT_PAD_ADD_NAME_SV; + + ASSERT_CURPAD_ACTIVE("pad_add_name"); + + if (typestash) { + assert(SvTYPE(namesv) == SVt_PVMG); + SvPAD_TYPED_on(namesv); + SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); + } + if (ourstash) { + SvPAD_OUR_on(namesv); + SvOURSTASH_set(namesv, ourstash); + SvREFCNT_inc_simple_void_NN(ourstash); + } + else if (flags & padadd_STATE) { + SvPAD_STATE_on(namesv); + } + + av_store(PL_comppad_name, offset, namesv); + return offset; +} + /* =for apidoc pad_add_name @@ -355,59 +384,53 @@ If fake, it means we're cloning an existing entry */ PADOFFSET -Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state) +Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, + HV *typestash, HV *ourstash) { dVAR; - const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); - SV* const namesv - = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); + PADOFFSET offset; + SV *namesv; PERL_ARGS_ASSERT_PAD_ADD_NAME; - ASSERT_CURPAD_ACTIVE("pad_add_name"); + if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK)) + Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf, + (UV)flags); + + namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); + + /* Until we're using the length for real, cross check that we're being told + the truth. */ + PERL_UNUSED_ARG(len); + assert(strlen(name) == len); sv_setpv(namesv, name); - if (typestash) { - assert(SvTYPE(namesv) == SVt_PVMG); - SvPAD_TYPED_on(namesv); - SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); - } - if (ourstash) { - SvPAD_OUR_on(namesv); - SvOURSTASH_set(namesv, ourstash); - SvREFCNT_inc_simple_void_NN(ourstash); - } - else if (state) { - SvPAD_STATE_on(namesv); + if ((flags & padadd_NO_DUP_CHECK) == 0) { + /* check for duplicate declaration */ + pad_check_dup(namesv, flags & padadd_OUR, ourstash); } - av_store(PL_comppad_name, offset, namesv); - if (fake) { - SvFAKE_on(namesv); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name)); - } - else { - /* not yet introduced */ - COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */ - COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */ - - if (!PL_min_intro_pending) - PL_min_intro_pending = offset; - PL_max_intro_pending = offset; - /* if it's not a simple scalar, replace with an AV or HV */ - /* XXX DAPM since slot has been allocated, replace - * av_store with PL_curpad[offset] ? */ - if (*name == '@') - av_store(PL_comppad, offset, MUTABLE_SV(newAV())); - else if (*name == '%') - av_store(PL_comppad, offset, MUTABLE_SV(newHV())); - SvPADMY_on(PL_curpad[offset]); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", - (long)offset, name, PTR2UV(PL_curpad[offset]))); - } + offset = pad_add_name_sv(namesv, flags, typestash, ourstash); + + /* not yet introduced */ + COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */ + COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */ + + if (!PL_min_intro_pending) + PL_min_intro_pending = offset; + PL_max_intro_pending = offset; + /* if it's not a simple scalar, replace with an AV or HV */ + /* XXX DAPM since slot has been allocated, replace + * av_store with PL_curpad[offset] ? */ + if (*name == '@') + av_store(PL_comppad, offset, MUTABLE_SV(newAV())); + else if (*name == '%') + av_store(PL_comppad, offset, MUTABLE_SV(newHV())); + SvPADMY_on(PL_curpad[offset]); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", + (long)offset, name, PTR2UV(PL_curpad[offset]))); return offset; } @@ -537,18 +560,20 @@ C<is_our> indicates that the name to check is an 'our' declaration =cut */ -/* XXX DAPM integrate this into pad_add_name ??? */ - -void -Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) +STATIC void +S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash) { dVAR; SV **svp; PADOFFSET top, off; + const U32 is_our = flags & padadd_OUR; PERL_ARGS_ASSERT_PAD_CHECK_DUP; ASSERT_CURPAD_ACTIVE("pad_check_dup"); + + assert((flags & ~padadd_OUR) == 0); + if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC)) return; /* nothing to check */ @@ -563,14 +588,14 @@ Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) && sv != &PL_sv_undef && !SvFAKE(sv) && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) - && strEQ(name, SvPVX_const(sv))) + && sv_eq(name, sv)) { if (is_our && (SvPAD_OUR(sv))) break; /* "our" masking "our" */ Perl_warner(aTHX_ packWARN(WARN_MISC), - "\"%s\" variable %s masks earlier declaration in same %s", + "\"%s\" variable %"SVf" masks earlier declaration in same %s", (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"), - name, + sv, (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement")); --off; break; @@ -585,10 +610,10 @@ Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) && !SvFAKE(sv) && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) && SvOURSTASH(sv) == ourstash - && strEQ(name, SvPVX_const(sv))) + && sv_eq(name, sv)) { Perl_warner(aTHX_ packWARN(WARN_MISC), - "\"our\" variable %s redeclared", name); + "\"our\" variable %"SVf" redeclared", sv); if ((I32)off <= PL_comppad_name_floor) Perl_warner(aTHX_ packWARN(WARN_MISC), "\t(Did you mean \"local\" instead of \"our\"?)\n"); @@ -612,7 +637,7 @@ Returns the offset in the current pad, or NOT_IN_PAD on failure. */ PADOFFSET -Perl_pad_findmy(pTHX_ const char *name) +Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags) { dVAR; SV *out_sv; @@ -624,6 +649,22 @@ Perl_pad_findmy(pTHX_ const char *name) PERL_ARGS_ASSERT_PAD_FINDMY; pad_peg("pad_findmy"); + + if (flags) + Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf, + (UV)flags); + + /* Yes, it is a bug (read work in progress) that we're not really using this + length parameter, and instead relying on strlen() later on. But I'm not + comfortable about changing the pad API piecemeal to use and rely on + lengths. This only exists to avoid an "unused parameter" warning. */ + if (len < 2) + return NOT_IN_PAD; + + /* But until we're using the length for real, cross check that we're being + told the truth. */ + assert(strlen(name) == len); + offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags); if ((PADOFFSET)offset != NOT_IN_PAD) @@ -865,23 +906,30 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, return 0; /* this dummy (and invalid) value isnt used by the caller */ { - SV *new_namesv; + /* This relies on sv_setsv_flags() upgrading the destination to the same + type as the source, independant of the flags set, and on it being + "good" and only copying flag bits and pointers that it understands. + */ + SV *new_namesv = newSVsv(*out_name_sv); AV * const ocomppad_name = PL_comppad_name; PAD * const ocomppad = PL_comppad; PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]); PL_curpad = AvARRAY(PL_comppad); - new_offset = pad_add_name( - SvPVX_const(*out_name_sv), - SvPAD_TYPED(*out_name_sv) - ? SvSTASH(*out_name_sv) : NULL, - SvOURSTASH(*out_name_sv), - 1, /* fake */ - SvPAD_STATE(*out_name_sv) ? 1 : 0 /* state variable ? */ - ); + new_offset + = pad_add_name_sv(new_namesv, + (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0), + SvPAD_TYPED(*out_name_sv) + ? SvSTASH(*out_name_sv) : NULL, + SvOURSTASH(*out_name_sv) + ); - new_namesv = AvARRAY(PL_comppad_name)[new_offset]; + SvFAKE_on(new_namesv); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad addname: %ld \"%.*s\" FAKE\n", + (long)new_offset, + (int) SvCUR(new_namesv), SvPVX(new_namesv))); PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags); PARENT_PAD_INDEX_set(new_namesv, 0); @@ -112,6 +112,16 @@ typedef enum { padtidy_FORMAT /* or a format */ } padtidy_type; +#ifdef PERL_CORE + +/* flags for pad_add_name. SVf_UTF8 will also be valid in the future. */ + +# define padadd_OUR 0x01 /* our declaration. */ +# define padadd_STATE 0x02 /* state declaration. */ +# define padadd_NO_DUP_CHECK 0x04 /* skip warning on dups. */ + +#endif + /* ASSERT_CURPAD_LEGAL and ASSERT_CURPAD_ACTIVE respectively determine * whether PL_comppad and PL_curpad are consistent and whether they have * active values */ @@ -107,6 +107,10 @@ typedef struct yy_parser { } yy_parser; +/* flags for lexer API */ +#define LEX_STUFF_UTF8 0x00000001 +#define LEX_KEEP_PREVIOUS 0x00000002 + /* * Local variables: * c-indentation-style: bsd diff --git a/patchlevel.h b/patchlevel.h index b628cbdf24..e882de2f64 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -15,7 +15,7 @@ #define PERL_REVISION 5 /* age */ #define PERL_VERSION 11 /* epoch */ -#define PERL_SUBVERSION 1 /* generation */ +#define PERL_SUBVERSION 2 /* generation */ /* The following numbers describe the earliest compatible version of Perl ("compatibility" here being defined as sufficient binary/API @@ -1,3 +1,4 @@ +#line 2 "perl.c" /* perl.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 @@ -539,6 +540,8 @@ perl_destruct(pTHXx) PERL_UNUSED_ARG(my_perl); #endif + assert(PL_scopestack_ix == 1); + /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -566,6 +569,7 @@ perl_destruct(pTHXx) } LEAVE; FREETMPS; + assert(PL_scopestack_ix == 0); /* Need to flush since END blocks can produce output */ my_fflush_all(); @@ -2606,8 +2610,6 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) - Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: @@ -2708,8 +2710,6 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) - Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: @@ -3222,9 +3222,11 @@ Perl_moreswitches(pTHX_ const char *s) } #endif PerlIO_printf(PerlIO_stdout(), - "\nThis is perl, %"SVf - " built for " ARCHNAME, - level); + "\nThis is perl " STRINGIFY(PERL_REVISION) + ", version " STRINGIFY(PERL_VERSION) + ", subversion " STRINGIFY(PERL_SUBVERSION) + " (%"SVf") built for " ARCHNAME, level + ); SvREFCNT_dec(level); } #else /* DGUX */ @@ -3813,6 +3815,9 @@ Perl_init_stacks(pTHX) SET_MARK_OFFSET; Newx(PL_scopestack,REASONABLE(32),I32); +#ifdef DEBUGGING + Newx(PL_scopestack_name,REASONABLE(32),const char*); +#endif PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); @@ -4581,16 +4586,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { - if (paramList == PL_beginav) - Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); - else - Perl_croak(aTHX_ "%s failed--call queue aborted", - paramList == PL_checkav ? "CHECK" - : paramList == PL_initav ? "INIT" - : paramList == PL_unitcheckav ? "UNITCHECK" - : "END"); - } my_exit_jump(); /* NOTREACHED */ case 3: @@ -28,7 +28,7 @@ #ifdef VOIDUSED # undef VOIDUSED -#endif +#endif #define VOIDUSED 1 #ifdef PERL_MICRO @@ -270,13 +270,13 @@ #define CALLREG_PACKAGE(rx) \ CALL_FPTR(RX_ENGINE(rx)->qr_package)(aTHX_ (rx)) -#if defined(USE_ITHREADS) +#if defined(USE_ITHREADS) #define CALLREGDUPE(prog,param) \ Perl_re_dup(aTHX_ (prog),(param)) #define CALLREGDUPE_PVT(prog,param) \ (prog ? CALL_FPTR(RX_ENGINE(prog)->dupe)(aTHX_ (prog),(param)) \ - : (REGEXP *)NULL) + : (REGEXP *)NULL) #endif @@ -310,7 +310,7 @@ # define PERL_UNUSED_DECL # endif #endif - + /* gcc -Wall: * for silencing unused variables that are actually used most of the time, * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs @@ -947,7 +947,7 @@ EXTERN_C int usleep(unsigned int); #define PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION #endif -/* Cannot include embed.h here on Win32 as win32.h has not +/* Cannot include embed.h here on Win32 as win32.h has not yet been included and defines some config variables e.g. HAVE_INTERP_INTERN */ #if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS)) @@ -1198,7 +1198,7 @@ EXTERN_C int usleep(unsigned int); #endif /* In Tru64 use the 4.4BSD struct msghdr, not the 4.3 one. - * This is important for using IPv6. + * This is important for using IPv6. * For OSF/1 3.2, however, defining _SOCKADDR_LEN would be * a bad idea since it breaks send() and recv(). */ #if defined(__osf__) && defined(__alpha) && !defined(_SOCKADDR_LEN) && !defined(DEC_OSF1_3_X) @@ -2780,7 +2780,7 @@ freeing any remaining Perl interpreters. # define HASATTRIBUTE_WARN_UNUSED_RESULT # endif #endif -#endif /* #ifndef PERL_MICRO */ +#endif /* #ifndef PERL_MICRO */ /* USE_5005THREADS needs to be after unixish.h as <pthread.h> includes * <sys/signal.h> which defines NSIG - which will stop inclusion of <signal.h> @@ -2871,7 +2871,7 @@ typedef pthread_key_t perl_key; /* This is complicated. The child processes return a true native VMS status which must be saved. But there is an assumption in Perl that the UNIX child status has some relationship to errno values, so - Perl tries to translate it to text in some of the tests. + Perl tries to translate it to text in some of the tests. In order to get the string translation correct, for the error, errno must be EVMSERR, but that generates a different text message than what the test programs are expecting. So an errno value must @@ -3131,16 +3131,16 @@ typedef pthread_key_t perl_key; # define PERL_SET_THX(t) PERL_SET_CONTEXT(t) #endif -/* +/* This replaces the previous %_ "hack" by the "%p" hacks. All that is required is that the perl source does not - use "%-p" or "%-<number>p" or "%<number>p" formats. - These formats will still work in perl code. + use "%-p" or "%-<number>p" or "%<number>p" formats. + These formats will still work in perl code. See comments in sv.c for futher details. Robin Barker 2005-07-14 - No longer use %1p for VDf = %vd. RMB 2007-10-19 + No longer use %1p for VDf = %vd. RMB 2007-10-19 */ #ifndef SVf_ @@ -3162,7 +3162,7 @@ typedef pthread_key_t perl_key; #define SVfARG(p) ((void*)(p)) #ifdef PERL_CORE -/* not used; but needed for backward compatibilty with XS code? - RMB */ +/* not used; but needed for backward compatibilty with XS code? - RMB */ # undef VDf #else # ifndef VDf @@ -3171,7 +3171,7 @@ typedef pthread_key_t perl_key; #endif #ifdef PERL_CORE -/* not used; but needed for backward compatibilty with XS code? - RMB */ +/* not used; but needed for backward compatibilty with XS code? - RMB */ # undef UVf #else # ifndef UVf @@ -3251,7 +3251,7 @@ typedef pthread_key_t perl_key; #ifdef PRINTF_FORMAT_NULL_OK # define __attribute__format__null_ok__(x,y,z) __attribute__format__(x,y,z) #else -# define __attribute__format__null_ok__(x,y,z) +# define __attribute__format__null_ok__(x,y,z) #endif #ifdef HAS_BUILTIN_EXPECT @@ -3354,7 +3354,7 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ #endif #ifdef __LIBCATAMOUNT__ -#undef HAS_PASSWD /* unixish.h but not unixish enough. */ +#undef HAS_PASSWD /* unixish.h but not unixish enough. */ #undef HAS_GROUP #define FAKE_BIT_BUCKET #endif @@ -4218,10 +4218,12 @@ EXTCONST char PL_warn_nl[] INIT("Unsuccessful %s on filename containing newline"); EXTCONST char PL_no_wrongref[] INIT("Can't use %s ref as %s ref"); -EXTCONST char PL_no_symref[] - INIT("Can't use string (\"%.32s\"%s) as %s ref while \"strict refs\" in use"); -EXTCONST char PL_no_symref_sv[] - INIT("Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use"); +/* The core no longer needs these here. If you require the string constant, + please inline a copy into your own code. */ +EXTCONST char PL_no_symref[] __attribute__deprecated__ + INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use"); +EXTCONST char PL_no_symref_sv[] __attribute__deprecated__ + INIT("Can't use string (\"%" SVf32 "\") as %s ref while \"strict refs\" in use"); EXTCONST char PL_no_usym[] INIT("Can't use an undefined value as %s reference"); EXTCONST char PL_no_aelem[] @@ -4345,9 +4347,85 @@ EXTCONST unsigned char PL_fold[] = { 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 }; -#endif /* !EBCDIC */ -#else +#endif /* !EBCDIC, but still in DOINIT */ + +/* If these tables are accessed through ebcdic, the access will be converted to + * latin1 first */ +EXTCONST unsigned char PL_latin1_lc[] = { /* lowercasing */ + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', + 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', + 'x', 'y', 'z', 91, 92, 93, 94, 95, + 96, 97, 98, 99, 100, 101, 102, 103, + 104, 105, 106, 107, 108, 109, 110, 111, + 112, 113, 114, 115, 116, 117, 118, 119, + 120, 121, 122, 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, + 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, + 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, + 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223, + 224, 225, 226, 227, 228, 229, 230, 231, + 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, + 248, 249, 250, 251, 252, 253, 254, 255 +}; + +/* upper and title case of latin1 characters, modified so that the three tricky + * ones are mapped to 255 (which is one of the three) */ +EXTCONST unsigned char PL_mod_latin1_uc[] = { + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 67, 68, 69, 70, 71, + 72, 73, 74, 75, 76, 77, 78, 79, + 80, 81, 82, 83, 84, 85, 86, 87, + 88, 89, 90, 91, 92, 93, 94, 95, + 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', + 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', + 'X', 'Y', 'Z', 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 255 /*micro*/, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192, 193, 194, 195, 196, 197, 198, 199, + 200, 201, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 211, 212, 213, 214, 215, + 216, 217, 218, 219, 220, 221, 222, 255 /*sharp s*/, + 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, + 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, + 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, + 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255 +}; +#else /* ! DOINIT */ EXTCONST unsigned char PL_fold[]; +EXTCONST unsigned char PL_mod_latin1_uc[]; +EXTCONST unsigned char PL_latin1_lc[]; #endif #ifndef PERL_GLOBAL_STRUCT /* or perlvars.h */ @@ -4677,6 +4755,7 @@ enum { /* pass one of these to get_vtbl */ #define HINT_BLOCK_SCOPE 0x00000100 #define HINT_STRICT_SUBS 0x00000200 /* strict pragma */ #define HINT_STRICT_VARS 0x00000400 /* strict pragma */ +#define HINT_NOT_UNI_8_BIT 0x00000800 /* unicode8bit pragma */ /* The HINT_NEW_* constants are used by the overload pragma */ #define HINT_NEW_INTEGER 0x00001000 @@ -4753,6 +4832,11 @@ typedef void (*XSUBADDR_t) (pTHX_ CV *); typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); typedef void(CPERLscope(*Perl_ophook_t))(pTHX_ OP*); +typedef int (CPERLscope(*Perl_keyword_plugin_t))(pTHX_ char*, STRLEN, OP**); + +#define KEYWORD_PLUGIN_DECLINE 0 +#define KEYWORD_PLUGIN_STMT 1 +#define KEYWORD_PLUGIN_EXPR 2 /* Interpreter exitlist entry */ typedef struct exitlistentry { @@ -5964,8 +6048,8 @@ extern void moncontrol(int); #define NO_ENV_ARRAY_IN_MAIN #endif -/* These are used by Perl_pv_escape() and Perl_pv_pretty() - * are here so that they are available throughout the core +/* These are used by Perl_pv_escape() and Perl_pv_pretty() + * are here so that they are available throughout the core * NOTE that even though some are for _escape and some for _pretty * there must not be any clashes as the flags from _pretty are * passed straight through to _escape. @@ -5979,7 +6063,7 @@ extern void moncontrol(int); #define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 -#define PERL_PV_ESCAPE_UNI 0x0100 +#define PERL_PV_ESCAPE_UNI 0x0100 #define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #define PERL_PV_ESCAPE_ALL 0x1000 @@ -566,6 +566,8 @@ END_EXTERN_C #define PL_scopestack_ix (*Perl_Iscopestack_ix_ptr(aTHX)) #undef PL_scopestack_max #define PL_scopestack_max (*Perl_Iscopestack_max_ptr(aTHX)) +#undef PL_scopestack_name +#define PL_scopestack_name (*Perl_Iscopestack_name_ptr(aTHX)) #undef PL_screamfirst #define PL_screamfirst (*Perl_Iscreamfirst_ptr(aTHX)) #undef PL_screamnext @@ -766,6 +768,8 @@ END_EXTERN_C #define PL_interp_size (*Perl_Ginterp_size_ptr(NULL)) #undef PL_interp_size_5_10_0 #define PL_interp_size_5_10_0 (*Perl_Ginterp_size_5_10_0_ptr(NULL)) +#undef PL_keyword_plugin +#define PL_keyword_plugin (*Perl_Gkeyword_plugin_ptr(NULL)) #undef PL_malloc_mutex #define PL_malloc_mutex (*Perl_Gmalloc_mutex_ptr(NULL)) #undef PL_mmap_page_size @@ -614,10 +614,8 @@ PerlIO_list_free(pTHX_ PerlIO_list_t *list) if (--list->refcnt == 0) { if (list->array) { IV i; - for (i = 0; i < list->cur; i++) { - if (list->array[i].arg) - SvREFCNT_dec(list->array[i].arg); - } + for (i = 0; i < list->cur; i++) + SvREFCNT_dec(list->array[i].arg); Safefree(list->array); } Safefree(list); @@ -1038,8 +1036,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) arg = newSVpvn(as, alen); PerlIO_list_push(aTHX_ av, layer, (arg) ? arg : &PL_sv_undef); - if (arg) - SvREFCNT_dec(arg); + SvREFCNT_dec(arg); } else { Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", @@ -1563,8 +1560,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0); PerlIO_list_push(aTHX_ layera, l->tab, (arg) ? arg : &PL_sv_undef); - if (arg) - SvREFCNT_dec(arg); + SvREFCNT_dec(arg); l = *PerlIONext(&l); } } @@ -2269,8 +2265,7 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); if (PerlIOBase(o)->flags & PERLIO_F_UTF8) PerlIOBase(f)->flags |= PERLIO_F_UTF8; - if (arg) - SvREFCNT_dec(arg); + SvREFCNT_dec(arg); } return f; } @@ -5181,8 +5176,7 @@ PerlIO_tmpfile(void) PerlIOBase(f)->flags |= PERLIO_F_TEMP; PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); } - if (sv) - SvREFCNT_dec(sv); + SvREFCNT_dec(sv); # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */ FILE * const stdio = PerlSIO_tmpfile(); diff --git a/perlvars.h b/perlvars.h index 49f4d5e31d..3d378917c9 100644 --- a/perlvars.h +++ b/perlvars.h @@ -8,9 +8,9 @@ * */ -/****************/ -/* Truly global */ -/****************/ +/* +=head1 Global Variables +*/ /* Don't forget to re-run embed.pl to propagate changes! */ @@ -186,3 +186,58 @@ PERLVARI(Gglobal_struct_size, U16, sizeof(struct perl_vars)) PERLVARI(Ginterp_size_5_10_0, U16, PERL_INTERPRETER_SIZE_UPTO_MEMBER(PERL_LAST_5_10_0_INTERP_MEMBER)) #endif + +/* +=for apidoc AmUx|Perl_keyword_plugin_t|PL_keyword_plugin + +Function pointer, pointing at a function used to handle extended keywords. +The function should be declared as + + int keyword_plugin_function(pTHX_ + char *keyword_ptr, STRLEN keyword_len, + OP **op_ptr) + +The function is called from the tokeniser, whenever a possible keyword +is seen. C<keyword_ptr> points at the word in the parser's input +buffer, and C<keyword_len> gives its length; it is not null-terminated. +The function is expected to examine the word, and possibly other state +such as L<%^H|perlvar/%^H>, to decide whether it wants to handle it +as an extended keyword. If it does not, the function should return +C<KEYWORD_PLUGIN_DECLINE>, and the normal parser process will continue. + +If the function wants to handle the keyword, it first must +parse anything following the keyword that is part of the syntax +introduced by the keyword. See L</Lexer interface> for details. + +When a keyword is being handled, the plugin function must build +a tree of C<OP> structures, representing the code that was parsed. +The root of the tree must be stored in C<*op_ptr>. The function then +returns a contant indicating the syntactic role of the construct that +it has parsed: C<KEYWORD_PLUGIN_STMT> if it is a complete statement, or +C<KEYWORD_PLUGIN_EXPR> if it is an expression. Note that a statement +construct cannot be used inside an expression (except via C<do BLOCK> +and similar), and an expression is not a complete statement (it requires +at least a terminating semicolon). + +When a keyword is handled, the plugin function may also have +(compile-time) side effects. It may modify C<%^H>, define functions, and +so on. Typically, if side effects are the main purpose of a handler, +it does not wish to generate any ops to be included in the normal +compilation. In this case it is still required to supply an op tree, +but it suffices to generate a single null op. + +That's how the C<*PL_keyword_plugin> function needs to behave overall. +Conventionally, however, one does not completely replace the existing +handler function. Instead, take a copy of C<PL_keyword_plugin> before +assigning your own function pointer to it. Your handler function should +look for keywords that it is interested in and handle those. Where it +is not interested, it should call the saved plugin function, passing on +the arguments it received. Thus C<PL_keyword_plugin> actually points +at a chain of handler functions, all of which have an opportunity to +handle keywords, and only the last function in the chain (built into +the Perl core) will normally return C<KEYWORD_PLUGIN_DECLINE>. + +=cut +*/ + +PERLVARI(Gkeyword_plugin, Perl_keyword_plugin_t, MEMBER_TO_FPTR(Perl_keyword_plugin_standard)) @@ -1,10 +1,10 @@ case 2: -#line 142 "perly.y" +#line 143 "perly.y" { (yyval.ival) = (ps[(1) - (2)].val.ival); newPROG(block_end((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval))); ;} break; case 3: -#line 147 "perly.y" +#line 148 "perly.y" { if (PL_parser->copline > (line_t)IVAL((ps[(1) - (4)].val.i_tkval))) PL_parser->copline = (line_t)IVAL((ps[(1) - (4)].val.i_tkval)); (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval)); @@ -14,24 +14,24 @@ case 2: break; case 4: -#line 156 "perly.y" +#line 157 "perly.y" { (yyval.ival) = block_start(TRUE); ;} break; case 5: -#line 160 "perly.y" - { (yyval.ival) = (I32) allocmy("$_"); ;} +#line 161 "perly.y" + { (yyval.ival) = (I32) Perl_allocmy(aTHX_ STR_WITH_LEN("$_"), 0); ;} break; case 6: -#line 164 "perly.y" +#line 165 "perly.y" { PL_parser->expect = XSTATE; (yyval.ival) = block_start(TRUE); ;} break; case 7: -#line 171 "perly.y" +#line 172 "perly.y" { if (PL_parser->copline > (line_t)IVAL((ps[(1) - (4)].val.i_tkval))) PL_parser->copline = (line_t)IVAL((ps[(1) - (4)].val.i_tkval)); (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval)); @@ -41,17 +41,17 @@ case 2: break; case 8: -#line 180 "perly.y" +#line 181 "perly.y" { (yyval.ival) = block_start(FALSE); ;} break; case 9: -#line 185 "perly.y" +#line 186 "perly.y" { (yyval.opval) = (OP*)NULL; ;} break; case 10: -#line 187 "perly.y" +#line 188 "perly.y" { (yyval.opval) = IF_MAD( append_list(OP_LINESEQ, @@ -61,7 +61,7 @@ case 2: break; case 11: -#line 194 "perly.y" +#line 195 "perly.y" { (yyval.opval) = append_list(OP_LINESEQ, (LISTOP*)(ps[(1) - (2)].val.opval), (LISTOP*)(ps[(2) - (2)].val.opval)); PL_pad_reset_pending = TRUE; @@ -71,23 +71,23 @@ case 2: break; case 12: -#line 204 "perly.y" +#line 205 "perly.y" { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (2)].val.p_tkval)), (ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.p_tkval),((LISTOP*)(yyval.opval))->op_first,'L'); ;} break; case 14: -#line 208 "perly.y" +#line 209 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 15: -#line 210 "perly.y" +#line 211 "perly.y" { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (2)].val.p_tkval)), (ps[(2) - (2)].val.opval)); ;} break; case 16: -#line 212 "perly.y" +#line 213 "perly.y" { if (PVAL((ps[(1) - (2)].val.p_tkval))) { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (2)].val.p_tkval)), newOP(OP_NULL, 0)); @@ -107,7 +107,7 @@ case 2: break; case 17: -#line 229 "perly.y" +#line 230 "perly.y" { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (3)].val.p_tkval)), (ps[(2) - (3)].val.opval)); PL_parser->expect = XSTATE; @@ -126,70 +126,75 @@ case 2: break; case 18: -#line 248 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 246 "perly.y" + { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (2)].val.p_tkval)), (ps[(2) - (2)].val.opval)); ;} break; case 19: -#line 250 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 251 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 20: -#line 252 "perly.y" +#line 253 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} + break; + + case 21: +#line 255 "perly.y" { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'i'); ;} break; - case 21: -#line 256 "perly.y" + case 22: +#line 259 "perly.y" { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'i'); ;} break; - case 22: -#line 260 "perly.y" + case 23: +#line 263 "perly.y" { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'w'); ;} break; - case 23: -#line 264 "perly.y" + case 24: +#line 267 "perly.y" { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'w'); ;} break; - case 24: -#line 268 "perly.y" + case 25: +#line 271 "perly.y" { (yyval.opval) = newFOROP(0, NULL, (line_t)IVAL((ps[(2) - (3)].val.i_tkval)), (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),((LISTOP*)(yyval.opval))->op_first->op_sibling,'w'); ;} break; - case 25: -#line 273 "perly.y" + case 26: +#line 276 "perly.y" { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), scope((ps[(1) - (3)].val.opval))); ;} break; - case 26: -#line 278 "perly.y" + case 27: +#line 281 "perly.y" { (yyval.opval) = (OP*)NULL; ;} break; - case 27: -#line 280 "perly.y" + case 28: +#line 283 "perly.y" { ((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS; (yyval.opval) = scope((ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 28: -#line 284 "perly.y" + case 29: +#line 287 "perly.y" { PL_parser->copline = (line_t)IVAL((ps[(1) - (6)].val.i_tkval)); (yyval.opval) = newCONDOP(0, newSTATEOP(OPf_SPECIAL,NULL,(ps[(3) - (6)].val.opval)), scope((ps[(5) - (6)].val.opval)), (ps[(6) - (6)].val.opval)); PL_hints |= HINT_BLOCK_SCOPE; @@ -199,8 +204,8 @@ case 2: ;} break; - case 29: -#line 295 "perly.y" + case 30: +#line 298 "perly.y" { PL_parser->copline = (line_t)IVAL((ps[(1) - (7)].val.i_tkval)); (yyval.opval) = block_end((ps[(3) - (7)].val.ival), newCONDOP(0, (ps[(4) - (7)].val.opval), scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval))); @@ -210,8 +215,8 @@ case 2: ;} break; - case 30: -#line 303 "perly.y" + case 31: +#line 306 "perly.y" { PL_parser->copline = (line_t)IVAL((ps[(1) - (7)].val.i_tkval)); (yyval.opval) = block_end((ps[(3) - (7)].val.ival), newCONDOP(0, (ps[(4) - (7)].val.opval), scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval))); @@ -221,31 +226,31 @@ case 2: ;} break; - case 31: -#line 314 "perly.y" + case 32: +#line 317 "perly.y" { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), scope((ps[(6) - (6)].val.opval)))); ;} break; - case 32: -#line 317 "perly.y" + case 33: +#line 320 "perly.y" { (yyval.opval) = newWHENOP(0, scope((ps[(2) - (2)].val.opval))); ;} break; - case 33: -#line 322 "perly.y" + case 34: +#line 325 "perly.y" { (yyval.opval) = (OP*)NULL; ;} break; - case 34: -#line 324 "perly.y" + case 35: +#line 327 "perly.y" { (yyval.opval) = scope((ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 35: -#line 331 "perly.y" + case 36: +#line 334 "perly.y" { OP *innerop; PL_parser->copline = (line_t)(ps[(2) - (9)].val.i_tkval); (yyval.opval) = block_end((ps[(4) - (9)].val.ival), @@ -259,8 +264,8 @@ case 2: ;} break; - case 36: -#line 344 "perly.y" + case 37: +#line 347 "perly.y" { OP *innerop; PL_parser->copline = (line_t)(ps[(2) - (9)].val.i_tkval); (yyval.opval) = block_end((ps[(4) - (9)].val.ival), @@ -274,8 +279,8 @@ case 2: ;} break; - case 37: -#line 356 "perly.y" + case 38: +#line 359 "perly.y" { OP *innerop; (yyval.opval) = block_end((ps[(4) - (10)].val.ival), innerop = newFOROP(0, PVAL((ps[(1) - (10)].val.p_tkval)), (line_t)IVAL((ps[(2) - (10)].val.i_tkval)), @@ -288,8 +293,8 @@ case 2: ;} break; - case 38: -#line 367 "perly.y" + case 39: +#line 370 "perly.y" { OP *innerop; (yyval.opval) = block_end((ps[(5) - (9)].val.ival), innerop = newFOROP(0, PVAL((ps[(1) - (9)].val.p_tkval)), (line_t)IVAL((ps[(2) - (9)].val.i_tkval)), @@ -301,8 +306,8 @@ case 2: ;} break; - case 39: -#line 377 "perly.y" + case 40: +#line 380 "perly.y" { OP *innerop; (yyval.opval) = block_end((ps[(4) - (8)].val.ival), innerop = newFOROP(0, PVAL((ps[(1) - (8)].val.p_tkval)), (line_t)IVAL((ps[(2) - (8)].val.i_tkval)), @@ -314,8 +319,8 @@ case 2: ;} break; - case 40: -#line 389 "perly.y" + case 41: +#line 392 "perly.y" { OP *forop; PL_parser->copline = (line_t)IVAL((ps[(2) - (12)].val.i_tkval)); forop = newSTATEOP(0, PVAL((ps[(1) - (12)].val.p_tkval)), @@ -347,16 +352,16 @@ case 2: (yyval.opval) = block_end((ps[(4) - (12)].val.ival), forop); ;} break; - case 41: -#line 419 "perly.y" + case 42: +#line 422 "perly.y" { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (3)].val.p_tkval)), newWHILEOP(0, 1, (LOOP*)(OP*)NULL, NOLINE, (OP*)NULL, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval), 0)); TOKEN_GETMAD((ps[(1) - (3)].val.p_tkval),((LISTOP*)(yyval.opval))->op_first,'L'); ;} break; - case 42: -#line 427 "perly.y" + case 43: +#line 430 "perly.y" { PL_parser->copline = (line_t) (ps[(2) - (8)].val.i_tkval); (yyval.opval) = block_end((ps[(4) - (8)].val.ival), newSTATEOP(0, PVAL((ps[(1) - (8)].val.p_tkval)), @@ -364,47 +369,47 @@ case 2: (PADOFFSET) (ps[(5) - (8)].val.ival)) )); ;} break; - case 43: -#line 436 "perly.y" + case 44: +#line 439 "perly.y" { (yyval.ival) = (PL_min_intro_pending && PL_max_intro_pending >= PL_min_intro_pending); intro_my(); ;} break; - case 44: -#line 442 "perly.y" + case 45: +#line 445 "perly.y" { (yyval.opval) = (OP*)NULL; ;} break; - case 46: -#line 448 "perly.y" + case 47: +#line 451 "perly.y" { YYSTYPE tmplval; (void)scan_num("1", &tmplval); (yyval.opval) = tmplval.opval; ;} break; - case 48: -#line 456 "perly.y" - { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;} - break; - case 49: -#line 461 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} +#line 459 "perly.y" + { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;} break; case 50: -#line 465 "perly.y" +#line 464 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} break; case 51: -#line 469 "perly.y" +#line 468 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} break; case 52: -#line 474 "perly.y" +#line 472 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} + break; + + case 53: +#line 477 "perly.y" { #ifdef MAD YYSTYPE tmplval; @@ -416,45 +421,45 @@ case 2: ;} break; - case 54: -#line 488 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} - break; - case 55: -#line 490 "perly.y" +#line 491 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 56: -#line 492 "perly.y" +#line 493 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 57: -#line 494 "perly.y" +#line 495 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 58: -#line 496 "perly.y" +#line 497 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 59: -#line 501 "perly.y" +#line 499 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 60: -#line 505 "perly.y" +#line 504 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} + break; + + case 61: +#line 508 "perly.y" { (yyval.opval) = newOP(OP_NULL,0); TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'p'); ;} break; - case 61: -#line 511 "perly.y" + case 62: +#line 514 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD (yyval.opval) = newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval)); @@ -468,18 +473,18 @@ case 2: ;} break; - case 62: -#line 524 "perly.y" + case 63: +#line 527 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; - case 63: -#line 525 "perly.y" + case 64: +#line 528 "perly.y" { (yyval.opval) = (OP*)NULL; ;} break; - case 64: -#line 530 "perly.y" + case 65: +#line 533 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD (yyval.opval) = newMYSUB((ps[(2) - (6)].val.ival), (ps[(3) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), (ps[(6) - (6)].val.opval)); @@ -491,8 +496,8 @@ case 2: ;} break; - case 65: -#line 543 "perly.y" + case 66: +#line 546 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD { @@ -514,26 +519,26 @@ case 2: ;} break; - case 66: -#line 565 "perly.y" + case 67: +#line 568 "perly.y" { (yyval.ival) = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); ;} break; - case 67: -#line 571 "perly.y" + case 68: +#line 574 "perly.y" { (yyval.ival) = start_subparse(FALSE, CVf_ANON); SAVEFREESV(PL_compcv); ;} break; - case 68: -#line 576 "perly.y" + case 69: +#line 579 "perly.y" { (yyval.ival) = start_subparse(TRUE, 0); SAVEFREESV(PL_compcv); ;} break; - case 69: -#line 581 "perly.y" + case 70: +#line 584 "perly.y" { const char *const name = SvPV_nolen_const(((SVOP*)(ps[(1) - (1)].val.opval))->op_sv); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT") || strEQ(name, "CHECK") @@ -542,25 +547,25 @@ case 2: (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; - case 70: -#line 591 "perly.y" + case 71: +#line 594 "perly.y" { (yyval.opval) = (OP*)NULL; ;} break; - case 72: -#line 597 "perly.y" + case 73: +#line 600 "perly.y" { (yyval.opval) = (OP*)NULL; ;} break; - case 73: -#line 599 "perly.y" + case 74: +#line 602 "perly.y" { (yyval.opval) = (ps[(2) - (2)].val.opval); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),':'); ;} break; - case 74: -#line 603 "perly.y" + case 75: +#line 606 "perly.y" { (yyval.opval) = IF_MAD( newOP(OP_NULL, 0), (OP*)NULL @@ -569,15 +574,15 @@ case 2: ;} break; - case 75: -#line 613 "perly.y" + case 76: +#line 616 "perly.y" { (yyval.opval) = (ps[(2) - (2)].val.opval); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),':'); ;} break; - case 76: -#line 617 "perly.y" + case 77: +#line 620 "perly.y" { (yyval.opval) = IF_MAD( newOP(OP_NULL, 0), (OP*)NULL @@ -586,13 +591,13 @@ case 2: ;} break; - case 77: -#line 626 "perly.y" + case 78: +#line 629 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; - case 78: -#line 627 "perly.y" + case 79: +#line 630 "perly.y" { (yyval.opval) = IF_MAD( newOP(OP_NULL,0), (OP*)NULL @@ -602,8 +607,8 @@ case 2: ;} break; - case 79: -#line 637 "perly.y" + case 80: +#line 640 "perly.y" { #ifdef MAD (yyval.opval) = package((ps[(3) - (4)].val.opval)); @@ -620,13 +625,13 @@ case 2: ;} break; - case 80: -#line 654 "perly.y" + case 81: +#line 657 "perly.y" { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ ;} break; - case 81: -#line 656 "perly.y" + case 82: +#line 659 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD (yyval.opval) = utilize(IVAL((ps[(1) - (7)].val.i_tkval)), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval)); @@ -642,29 +647,29 @@ case 2: ;} break; - case 82: -#line 673 "perly.y" + case 83: +#line 676 "perly.y" { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 83: -#line 677 "perly.y" + case 84: +#line 680 "perly.y" { (yyval.opval) = newLOGOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 84: -#line 681 "perly.y" + case 85: +#line 684 "perly.y" { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 86: -#line 689 "perly.y" + case 87: +#line 692 "perly.y" { #ifdef MAD OP* op = newNULLLIST(); @@ -676,8 +681,8 @@ case 2: ;} break; - case 87: -#line 699 "perly.y" + case 88: +#line 702 "perly.y" { OP* term = (ps[(3) - (3)].val.opval); DO_MAD( @@ -688,16 +693,16 @@ case 2: ;} break; - case 89: -#line 712 "perly.y" + case 90: +#line 715 "perly.y" { (yyval.opval) = convert(IVAL((ps[(1) - (3)].val.i_tkval)), OPf_STACKED, prepend_elem(OP_LIST, newGVREF(IVAL((ps[(1) - (3)].val.i_tkval)),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) ); TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 90: -#line 717 "perly.y" + case 91: +#line 720 "perly.y" { (yyval.opval) = convert(IVAL((ps[(1) - (5)].val.i_tkval)), OPf_STACKED, prepend_elem(OP_LIST, newGVREF(IVAL((ps[(1) - (5)].val.i_tkval)),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) ); TOKEN_GETMAD((ps[(1) - (5)].val.i_tkval),(yyval.opval),'o'); @@ -706,8 +711,8 @@ case 2: ;} break; - case 91: -#line 724 "perly.y" + case 92: +#line 727 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)), @@ -718,8 +723,8 @@ case 2: ;} break; - case 92: -#line 733 "perly.y" + case 93: +#line 736 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)), newUNOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval)))); @@ -727,8 +732,8 @@ case 2: ;} break; - case 93: -#line 739 "perly.y" + case 94: +#line 742 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)), @@ -736,8 +741,8 @@ case 2: ;} break; - case 94: -#line 745 "perly.y" + case 95: +#line 748 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)), @@ -747,15 +752,15 @@ case 2: ;} break; - case 95: -#line 753 "perly.y" + case 96: +#line 756 "perly.y" { (yyval.opval) = convert(IVAL((ps[(1) - (2)].val.i_tkval)), 0, (ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 96: -#line 757 "perly.y" + case 97: +#line 760 "perly.y" { (yyval.opval) = convert(IVAL((ps[(1) - (4)].val.i_tkval)), 0, (ps[(3) - (4)].val.opval)); TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'o'); TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'('); @@ -763,22 +768,22 @@ case 2: ;} break; - case 97: -#line 763 "perly.y" + case 98: +#line 766 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); ;} break; - case 98: -#line 766 "perly.y" + case 99: +#line 769 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)), (ps[(1) - (5)].val.opval))); ;} break; - case 101: -#line 781 "perly.y" + case 102: +#line 784 "perly.y" { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); PL_parser->expect = XOPERATOR; TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'{'); @@ -787,16 +792,16 @@ case 2: ;} break; - case 102: -#line 788 "perly.y" + case 103: +#line 791 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[(1) - (4)].val.opval)), scalar((ps[(3) - (4)].val.opval))); TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'['); TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),']'); ;} break; - case 103: -#line 793 "perly.y" + case 104: +#line 796 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, ref(newAVREF((ps[(1) - (5)].val.opval)),OP_RV2AV), scalar((ps[(4) - (5)].val.opval))); @@ -806,8 +811,8 @@ case 2: ;} break; - case 104: -#line 801 "perly.y" + case 105: +#line 804 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, ref(newAVREF((ps[(1) - (4)].val.opval)),OP_RV2AV), scalar((ps[(3) - (4)].val.opval))); @@ -816,8 +821,8 @@ case 2: ;} break; - case 105: -#line 808 "perly.y" + case 106: +#line 811 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[(1) - (5)].val.opval)), jmaybe((ps[(3) - (5)].val.opval))); PL_parser->expect = XOPERATOR; TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'{'); @@ -826,8 +831,8 @@ case 2: ;} break; - case 106: -#line 815 "perly.y" + case 107: +#line 818 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, ref(newHVREF((ps[(1) - (6)].val.opval)),OP_RV2HV), jmaybe((ps[(4) - (6)].val.opval))); @@ -839,8 +844,8 @@ case 2: ;} break; - case 107: -#line 825 "perly.y" + case 108: +#line 828 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, ref(newHVREF((ps[(1) - (5)].val.opval)),OP_RV2HV), jmaybe((ps[(3) - (5)].val.opval))); @@ -851,8 +856,8 @@ case 2: ;} break; - case 108: -#line 834 "perly.y" + case 109: +#line 837 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'a'); @@ -861,8 +866,8 @@ case 2: ;} break; - case 109: -#line 841 "perly.y" + case 110: +#line 844 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, (ps[(4) - (5)].val.opval), newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); @@ -872,8 +877,8 @@ case 2: ;} break; - case 110: -#line 850 "perly.y" + case 111: +#line 853 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, (ps[(3) - (4)].val.opval), newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); @@ -882,8 +887,8 @@ case 2: ;} break; - case 111: -#line 857 "perly.y" + case 112: +#line 860 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'('); @@ -891,8 +896,8 @@ case 2: ;} break; - case 112: -#line 863 "perly.y" + case 113: +#line 866 "perly.y" { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); TOKEN_GETMAD((ps[(1) - (6)].val.i_tkval),(yyval.opval),'('); TOKEN_GETMAD((ps[(3) - (6)].val.i_tkval),(yyval.opval),')'); @@ -901,8 +906,8 @@ case 2: ;} break; - case 113: -#line 870 "perly.y" + case 114: +#line 873 "perly.y" { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); TOKEN_GETMAD((ps[(1) - (5)].val.i_tkval),(yyval.opval),'('); TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),')'); @@ -911,22 +916,22 @@ case 2: ;} break; - case 114: -#line 880 "perly.y" + case 115: +#line 883 "perly.y" { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), IVAL((ps[(2) - (3)].val.i_tkval)), (ps[(3) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 115: -#line 884 "perly.y" + case 116: +#line 887 "perly.y" { (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 116: -#line 888 "perly.y" + case 117: +#line 891 "perly.y" { if (IVAL((ps[(2) - (3)].val.i_tkval)) != OP_REPEAT) scalar((ps[(1) - (3)].val.opval)); (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval))); @@ -934,50 +939,50 @@ case 2: ;} break; - case 117: -#line 894 "perly.y" - { (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); - TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); - ;} - break; - case 118: -#line 898 "perly.y" +#line 897 "perly.y" { (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; case 119: -#line 902 "perly.y" +#line 901 "perly.y" { (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; case 120: -#line 906 "perly.y" +#line 905 "perly.y" { (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; case 121: -#line 910 "perly.y" +#line 909 "perly.y" { (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; case 122: -#line 914 "perly.y" +#line 913 "perly.y" { (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; case 123: -#line 918 "perly.y" +#line 917 "perly.y" + { (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); + TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); + ;} + break; + + case 124: +#line 921 "perly.y" { (yyval.opval) = newRANGE(IVAL((ps[(2) - (3)].val.i_tkval)), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); DO_MAD({ @@ -991,29 +996,29 @@ case 2: ;} break; - case 124: -#line 930 "perly.y" + case 125: +#line 933 "perly.y" { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 125: -#line 934 "perly.y" + case 126: +#line 937 "perly.y" { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 126: -#line 938 "perly.y" + case 127: +#line 941 "perly.y" { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 127: -#line 942 "perly.y" + case 128: +#line 945 "perly.y" { (yyval.opval) = bind_match(IVAL((ps[(2) - (3)].val.i_tkval)), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval), ((yyval.opval)->op_type == OP_NOT @@ -1022,15 +1027,15 @@ case 2: ;} break; - case 128: -#line 952 "perly.y" + case 129: +#line 955 "perly.y" { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 129: -#line 956 "perly.y" + case 130: +#line 959 "perly.y" { (yyval.opval) = IF_MAD( newUNOP(OP_NULL, 0, (ps[(2) - (2)].val.opval)), (ps[(2) - (2)].val.opval) @@ -1039,70 +1044,70 @@ case 2: ;} break; - case 130: -#line 963 "perly.y" + case 131: +#line 966 "perly.y" { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 131: -#line 967 "perly.y" + case 132: +#line 970 "perly.y" { (yyval.opval) = newUNOP(OP_COMPLEMENT, 0, scalar((ps[(2) - (2)].val.opval))); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 132: -#line 971 "perly.y" + case 133: +#line 974 "perly.y" { (yyval.opval) = newUNOP(OP_POSTINC, 0, mod(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 133: -#line 976 "perly.y" + case 134: +#line 979 "perly.y" { (yyval.opval) = newUNOP(OP_POSTDEC, 0, mod(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC)); TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 134: -#line 981 "perly.y" + case 135: +#line 984 "perly.y" { (yyval.opval) = newUNOP(OP_PREINC, 0, mod(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 135: -#line 986 "perly.y" + case 136: +#line 989 "perly.y" { (yyval.opval) = newUNOP(OP_PREDEC, 0, mod(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 136: -#line 995 "perly.y" + case 137: +#line 998 "perly.y" { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'['); TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),']'); ;} break; - case 137: -#line 1000 "perly.y" + case 138: +#line 1003 "perly.y" { (yyval.opval) = newANONLIST((OP*)NULL); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'['); TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),']'); ;} break; - case 138: -#line 1005 "perly.y" + case 139: +#line 1008 "perly.y" { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'{'); TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),';'); @@ -1110,8 +1115,8 @@ case 2: ;} break; - case 139: -#line 1011 "perly.y" + case 140: +#line 1014 "perly.y" { (yyval.opval) = newANONHASH((OP*)NULL); TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'{'); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),';'); @@ -1119,8 +1124,8 @@ case 2: ;} break; - case 140: -#line 1017 "perly.y" + case 141: +#line 1020 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); TOKEN_GETMAD((ps[(1) - (5)].val.i_tkval),(yyval.opval),'o'); @@ -1129,22 +1134,22 @@ case 2: ;} break; - case 141: -#line 1028 "perly.y" + case 142: +#line 1031 "perly.y" { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), IVAL((ps[(1) - (2)].val.i_tkval))); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 142: -#line 1032 "perly.y" + case 143: +#line 1035 "perly.y" { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, scope((ps[(2) - (2)].val.opval))); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'D'); ;} break; - case 143: -#line 1036 "perly.y" + case 144: +#line 1039 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -1158,8 +1163,8 @@ case 2: ;} break; - case 144: -#line 1048 "perly.y" + case 145: +#line 1051 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -1174,8 +1179,8 @@ case 2: ;} break; - case 145: -#line 1061 "perly.y" + case 146: +#line 1064 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar((ps[(2) - (4)].val.opval)))), (OP*)NULL)); dep(); @@ -1185,8 +1190,8 @@ case 2: ;} break; - case 146: -#line 1069 "perly.y" + case 147: +#line 1072 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), @@ -1197,81 +1202,81 @@ case 2: ;} break; - case 151: -#line 1085 "perly.y" + case 152: +#line 1088 "perly.y" { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'?'); TOKEN_GETMAD((ps[(4) - (5)].val.i_tkval),(yyval.opval),':'); ;} break; - case 152: -#line 1090 "perly.y" + case 153: +#line 1093 "perly.y" { (yyval.opval) = newUNOP(OP_REFGEN, 0, mod((ps[(2) - (2)].val.opval),OP_REFGEN)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 153: -#line 1094 "perly.y" + case 154: +#line 1097 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; - case 154: -#line 1096 "perly.y" + case 155: +#line 1099 "perly.y" { (yyval.opval) = localize((ps[(2) - (2)].val.opval),IVAL((ps[(1) - (2)].val.i_tkval))); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'k'); ;} break; - case 155: -#line 1100 "perly.y" + case 156: +#line 1103 "perly.y" { (yyval.opval) = sawparens(IF_MAD(newUNOP(OP_NULL,0,(ps[(2) - (3)].val.opval)), (ps[(2) - (3)].val.opval))); TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'('); TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')'); ;} break; - case 156: -#line 1105 "perly.y" + case 157: +#line 1108 "perly.y" { (yyval.opval) = sawparens(newNULLLIST()); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'('); TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),')'); ;} break; - case 157: -#line 1110 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} - break; - case 158: -#line 1112 "perly.y" +#line 1113 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 159: -#line 1114 "perly.y" +#line 1115 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 160: -#line 1116 "perly.y" +#line 1117 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 161: -#line 1118 "perly.y" - { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;} +#line 1119 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 162: -#line 1120 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 1121 "perly.y" + { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;} break; case 163: -#line 1122 "perly.y" +#line 1123 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} + break; + + case 164: +#line 1125 "perly.y" { (yyval.opval) = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -1282,8 +1287,8 @@ case 2: ;} break; - case 164: -#line 1131 "perly.y" + case 165: +#line 1134 "perly.y" { (yyval.opval) = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -1296,26 +1301,26 @@ case 2: ;} break; - case 165: -#line 1142 "perly.y" + case 166: +#line 1145 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; - case 166: -#line 1144 "perly.y" + case 167: +#line 1147 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); ;} break; - case 167: -#line 1146 "perly.y" + case 168: +#line 1149 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (3)].val.opval))); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'('); TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')'); ;} break; - case 168: -#line 1151 "perly.y" + case 169: +#line 1154 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, (ps[(3) - (4)].val.opval), scalar((ps[(1) - (4)].val.opval)))); @@ -1330,91 +1335,91 @@ case 2: ;} break; - case 169: -#line 1164 "perly.y" + case 170: +#line 1167 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, (ps[(3) - (3)].val.opval), scalar((ps[(2) - (3)].val.opval)))); TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 170: -#line 1169 "perly.y" + case 171: +#line 1172 "perly.y" { (yyval.opval) = newOP(IVAL((ps[(1) - (1)].val.i_tkval)), OPf_SPECIAL); PL_hints |= HINT_BLOCK_SCOPE; TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 171: -#line 1174 "perly.y" + case 172: +#line 1177 "perly.y" { (yyval.opval) = newLOOPEX(IVAL((ps[(1) - (2)].val.i_tkval)),(ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 172: -#line 1178 "perly.y" + case 173: +#line 1181 "perly.y" { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 173: -#line 1182 "perly.y" + case 174: +#line 1185 "perly.y" { (yyval.opval) = newOP(IVAL((ps[(1) - (1)].val.i_tkval)), 0); TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 174: -#line 1186 "perly.y" + case 175: +#line 1189 "perly.y" { (yyval.opval) = newUNOP(IVAL((ps[(1) - (2)].val.i_tkval)), 0, (ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 175: -#line 1190 "perly.y" + case 176: +#line 1193 "perly.y" { (yyval.opval) = newUNOP(IVAL((ps[(1) - (2)].val.i_tkval)), 0, (ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 176: -#line 1194 "perly.y" + case 177: +#line 1197 "perly.y" { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.i_tkval) ? OPf_SPECIAL : 0); TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 177: -#line 1198 "perly.y" + case 178: +#line 1201 "perly.y" { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.i_tkval) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 178: -#line 1202 "perly.y" + case 179: +#line 1205 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;} break; - case 179: -#line 1204 "perly.y" + case 180: +#line 1207 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); ;} break; - case 180: -#line 1207 "perly.y" + case 181: +#line 1210 "perly.y" { (yyval.opval) = newOP(IVAL((ps[(1) - (1)].val.i_tkval)), 0); TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'o'); ;} break; - case 181: -#line 1211 "perly.y" + case 182: +#line 1214 "perly.y" { (yyval.opval) = newOP(IVAL((ps[(1) - (3)].val.i_tkval)), 0); TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'o'); TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'('); @@ -1422,14 +1427,14 @@ case 2: ;} break; - case 182: -#line 1217 "perly.y" + case 183: +#line 1220 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;} break; - case 183: -#line 1220 "perly.y" + case 184: +#line 1223 "perly.y" { (yyval.opval) = (IVAL((ps[(1) - (3)].val.i_tkval)) == OP_NOT) ? newUNOP(IVAL((ps[(1) - (3)].val.i_tkval)), 0, newSVOP(OP_CONST, 0, newSViv(0))) : newOP(IVAL((ps[(1) - (3)].val.i_tkval)), OPf_SPECIAL); @@ -1440,8 +1445,8 @@ case 2: ;} break; - case 184: -#line 1229 "perly.y" + case 185: +#line 1232 "perly.y" { (yyval.opval) = newUNOP(IVAL((ps[(1) - (4)].val.i_tkval)), 0, (ps[(3) - (4)].val.opval)); TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'o'); TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'('); @@ -1449,16 +1454,16 @@ case 2: ;} break; - case 185: -#line 1235 "perly.y" + case 186: +#line 1238 "perly.y" { (yyval.opval) = pmruntime((ps[(1) - (4)].val.opval), (ps[(3) - (4)].val.opval), 1); TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'('); TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),')'); ;} break; - case 188: -#line 1242 "perly.y" + case 189: +#line 1245 "perly.y" { (yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); @@ -1466,8 +1471,8 @@ case 2: ;} break; - case 189: -#line 1251 "perly.y" + case 191: +#line 1255 "perly.y" { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); DO_MAD( token_getmad((ps[(1) - (3)].val.i_tkval),(yyval.opval),'d'); @@ -1477,66 +1482,66 @@ case 2: ;} break; - case 190: -#line 1259 "perly.y" + case 192: +#line 1263 "perly.y" { (yyval.opval) = localize((ps[(2) - (2)].val.opval),IVAL((ps[(1) - (2)].val.i_tkval))); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'d'); ;} break; - case 191: -#line 1266 "perly.y" + case 193: +#line 1270 "perly.y" { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'('); TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')'); ;} break; - case 192: -#line 1271 "perly.y" + case 194: +#line 1275 "perly.y" { (yyval.opval) = sawparens(newNULLLIST()); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'('); TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),')'); ;} break; - case 193: -#line 1276 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} - break; - - case 194: -#line 1278 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} - break; - case 195: #line 1280 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 196: -#line 1285 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 1282 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 197: -#line 1287 "perly.y" +#line 1284 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 198: -#line 1291 "perly.y" +#line 1289 "perly.y" { (yyval.opval) = (OP*)NULL; ;} break; case 199: -#line 1293 "perly.y" +#line 1291 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 200: #line 1295 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} + break; + + case 201: +#line 1297 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} + break; + + case 202: +#line 1299 "perly.y" { #ifdef MAD OP* op = newNULLLIST(); @@ -1549,70 +1554,70 @@ case 2: ;} break; - case 201: -#line 1310 "perly.y" + case 203: +#line 1314 "perly.y" { PL_parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); ;} break; - case 202: -#line 1314 "perly.y" + case 204: +#line 1318 "perly.y" { (yyval.opval) = newCVREF(IVAL((ps[(1) - (2)].val.i_tkval)),(ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'&'); ;} break; - case 203: -#line 1320 "perly.y" + case 205: +#line 1324 "perly.y" { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'$'); ;} break; - case 204: -#line 1326 "perly.y" + case 206: +#line 1330 "perly.y" { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'@'); ;} break; - case 205: -#line 1332 "perly.y" + case 207: +#line 1336 "perly.y" { (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'%'); ;} break; - case 206: -#line 1338 "perly.y" + case 208: +#line 1342 "perly.y" { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'l'); ;} break; - case 207: -#line 1344 "perly.y" + case 209: +#line 1348 "perly.y" { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'*'); ;} break; - case 208: -#line 1351 "perly.y" + case 210: +#line 1355 "perly.y" { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;} break; - case 209: -#line 1353 "perly.y" + case 211: +#line 1357 "perly.y" { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;} break; - case 210: -#line 1355 "perly.y" + case 212: +#line 1359 "perly.y" { (yyval.opval) = scope((ps[(1) - (1)].val.opval)); ;} break; - case 211: -#line 1358 "perly.y" + case 213: +#line 1362 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; @@ -49,66 +49,68 @@ FUNC0SUB = 264, UNIOPSUB = 265, LSTOPSUB = 266, - LABEL = 267, - FORMAT = 268, - SUB = 269, - ANONSUB = 270, - PACKAGE = 271, - USE = 272, - WHILE = 273, - UNTIL = 274, - IF = 275, - UNLESS = 276, - ELSE = 277, - ELSIF = 278, - CONTINUE = 279, - FOR = 280, - GIVEN = 281, - WHEN = 282, - DEFAULT = 283, - LOOPEX = 284, - DOTDOT = 285, - YADAYADA = 286, - FUNC0 = 287, - FUNC1 = 288, - FUNC = 289, - UNIOP = 290, - LSTOP = 291, - RELOP = 292, - EQOP = 293, - MULOP = 294, - ADDOP = 295, - DOLSHARP = 296, - DO = 297, - HASHBRACK = 298, - NOAMP = 299, - LOCAL = 300, - MY = 301, - MYSUB = 302, - REQUIRE = 303, - COLONATTR = 304, - PREC_LOW = 305, - DOROP = 306, - OROP = 307, - ANDOP = 308, - NOTOP = 309, - ASSIGNOP = 310, - DORDOR = 311, - OROR = 312, - ANDAND = 313, - BITOROP = 314, - BITANDOP = 315, - SHIFTOP = 316, - MATCHOP = 317, - REFGEN = 318, - UMINUS = 319, - POWOP = 320, - POSTDEC = 321, - POSTINC = 322, - PREDEC = 323, - PREINC = 324, - ARROW = 325, - PEG = 326 + PLUGEXPR = 267, + PLUGSTMT = 268, + LABEL = 269, + FORMAT = 270, + SUB = 271, + ANONSUB = 272, + PACKAGE = 273, + USE = 274, + WHILE = 275, + UNTIL = 276, + IF = 277, + UNLESS = 278, + ELSE = 279, + ELSIF = 280, + CONTINUE = 281, + FOR = 282, + GIVEN = 283, + WHEN = 284, + DEFAULT = 285, + LOOPEX = 286, + DOTDOT = 287, + YADAYADA = 288, + FUNC0 = 289, + FUNC1 = 290, + FUNC = 291, + UNIOP = 292, + LSTOP = 293, + RELOP = 294, + EQOP = 295, + MULOP = 296, + ADDOP = 297, + DOLSHARP = 298, + DO = 299, + HASHBRACK = 300, + NOAMP = 301, + LOCAL = 302, + MY = 303, + MYSUB = 304, + REQUIRE = 305, + COLONATTR = 306, + PREC_LOW = 307, + DOROP = 308, + OROP = 309, + ANDOP = 310, + NOTOP = 311, + ASSIGNOP = 312, + DORDOR = 313, + OROR = 314, + ANDAND = 315, + BITOROP = 316, + BITANDOP = 317, + SHIFTOP = 318, + MATCHOP = 319, + REFGEN = 320, + UMINUS = 321, + POWOP = 322, + POSTDEC = 323, + POSTINC = 324, + PREDEC = 325, + PREINC = 326, + ARROW = 327, + PEG = 328 }; #endif @@ -122,66 +124,68 @@ #define FUNC0SUB 264 #define UNIOPSUB 265 #define LSTOPSUB 266 -#define LABEL 267 -#define FORMAT 268 -#define SUB 269 -#define ANONSUB 270 -#define PACKAGE 271 -#define USE 272 -#define WHILE 273 -#define UNTIL 274 -#define IF 275 -#define UNLESS 276 -#define ELSE 277 -#define ELSIF 278 -#define CONTINUE 279 -#define FOR 280 -#define GIVEN 281 -#define WHEN 282 -#define DEFAULT 283 -#define LOOPEX 284 -#define DOTDOT 285 -#define YADAYADA 286 -#define FUNC0 287 -#define FUNC1 288 -#define FUNC 289 -#define UNIOP 290 -#define LSTOP 291 -#define RELOP 292 -#define EQOP 293 -#define MULOP 294 -#define ADDOP 295 -#define DOLSHARP 296 -#define DO 297 -#define HASHBRACK 298 -#define NOAMP 299 -#define LOCAL 300 -#define MY 301 -#define MYSUB 302 -#define REQUIRE 303 -#define COLONATTR 304 -#define PREC_LOW 305 -#define DOROP 306 -#define OROP 307 -#define ANDOP 308 -#define NOTOP 309 -#define ASSIGNOP 310 -#define DORDOR 311 -#define OROR 312 -#define ANDAND 313 -#define BITOROP 314 -#define BITANDOP 315 -#define SHIFTOP 316 -#define MATCHOP 317 -#define REFGEN 318 -#define UMINUS 319 -#define POWOP 320 -#define POSTDEC 321 -#define POSTINC 322 -#define PREDEC 323 -#define PREINC 324 -#define ARROW 325 -#define PEG 326 +#define PLUGEXPR 267 +#define PLUGSTMT 268 +#define LABEL 269 +#define FORMAT 270 +#define SUB 271 +#define ANONSUB 272 +#define PACKAGE 273 +#define USE 274 +#define WHILE 275 +#define UNTIL 276 +#define IF 277 +#define UNLESS 278 +#define ELSE 279 +#define ELSIF 280 +#define CONTINUE 281 +#define FOR 282 +#define GIVEN 283 +#define WHEN 284 +#define DEFAULT 285 +#define LOOPEX 286 +#define DOTDOT 287 +#define YADAYADA 288 +#define FUNC0 289 +#define FUNC1 290 +#define FUNC 291 +#define UNIOP 292 +#define LSTOP 293 +#define RELOP 294 +#define EQOP 295 +#define MULOP 296 +#define ADDOP 297 +#define DOLSHARP 298 +#define DO 299 +#define HASHBRACK 300 +#define NOAMP 301 +#define LOCAL 302 +#define MY 303 +#define MYSUB 304 +#define REQUIRE 305 +#define COLONATTR 306 +#define PREC_LOW 307 +#define DOROP 308 +#define OROP 309 +#define ANDOP 310 +#define NOTOP 311 +#define ASSIGNOP 312 +#define DORDOR 313 +#define OROR 314 +#define ANDAND 315 +#define BITOROP 316 +#define BITANDOP 317 +#define SHIFTOP 318 +#define MATCHOP 319 +#define REFGEN 320 +#define UMINUS 321 +#define POWOP 322 +#define POSTDEC 323 +#define POSTINC 324 +#define PREDEC 325 +#define PREINC 326 +#define ARROW 327 +#define PEG 328 @@ -1,19 +1,19 @@ #define YYFINAL 3 /* YYLAST -- Last index in YYTABLE. */ -#define YYLAST 2062 +#define YYLAST 2074 /* YYNTOKENS -- Number of terminals. */ -#define YYNTOKENS 91 +#define YYNTOKENS 93 /* YYNNTS -- Number of nonterminals. */ #define YYNNTS 65 /* YYNRULES -- Number of rules. */ -#define YYNRULES 211 +#define YYNRULES 213 /* YYNRULES -- Number of states. */ -#define YYNSTATES 423 +#define YYNSTATES 425 /* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ #define YYUNDEFTOK 2 -#define YYMAXUTOK 326 +#define YYMAXUTOK 328 #define YYTRANSLATE(YYX) \ ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) @@ -24,16 +24,16 @@ static const yytype_uint8 yytranslate[] = 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 78, 2, 2, 9, 11, 13, 2, - 89, 88, 12, 8, 67, 7, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 70, 14, - 2, 2, 2, 69, 10, 2, 2, 2, 2, 2, + 2, 2, 2, 80, 2, 2, 9, 11, 13, 2, + 91, 90, 12, 8, 69, 7, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 72, 14, + 2, 2, 2, 71, 10, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 5, 2, 6, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 3, 2, 4, 79, 2, 2, 2, + 2, 2, 2, 3, 2, 4, 81, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -52,8 +52,8 @@ static const yytype_uint8 yytranslate[] = 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, - 68, 71, 72, 73, 74, 75, 76, 77, 80, 81, - 82, 83, 84, 85, 86, 87, 90 + 67, 68, 70, 73, 74, 75, 76, 77, 78, 79, + 82, 83, 84, 85, 86, 87, 88, 89, 92 }; #if YYDEBUG @@ -62,133 +62,134 @@ static const yytype_uint8 yytranslate[] = static const yytype_uint16 yyprhs[] = { 0, 0, 3, 6, 11, 12, 13, 14, 19, 20, - 21, 24, 27, 30, 32, 34, 37, 40, 44, 46, - 48, 52, 56, 60, 64, 68, 72, 73, 76, 83, - 91, 99, 106, 109, 110, 113, 123, 133, 144, 154, - 163, 176, 180, 189, 190, 191, 193, 194, 196, 198, - 200, 202, 204, 205, 207, 209, 211, 213, 215, 217, - 219, 221, 226, 228, 229, 236, 243, 244, 245, 246, - 248, 249, 251, 252, 255, 257, 260, 262, 264, 266, - 271, 272, 280, 284, 288, 292, 294, 297, 301, 303, - 307, 313, 320, 324, 328, 334, 337, 342, 343, 349, - 351, 353, 359, 364, 370, 375, 381, 388, 394, 399, - 405, 410, 414, 421, 427, 431, 435, 439, 443, 447, - 451, 455, 459, 463, 467, 471, 475, 479, 483, 486, - 489, 492, 495, 498, 501, 504, 507, 511, 514, 519, - 523, 529, 532, 535, 540, 546, 551, 557, 559, 561, - 563, 565, 571, 574, 576, 579, 583, 586, 588, 590, - 592, 594, 596, 598, 603, 609, 611, 613, 617, 622, - 626, 628, 631, 634, 636, 639, 642, 644, 647, 649, - 652, 654, 658, 660, 664, 669, 674, 676, 678, 680, - 684, 687, 691, 694, 696, 698, 700, 701, 703, 704, - 706, 709, 711, 714, 717, 720, 723, 726, 729, 731, - 733, 735 + 21, 24, 27, 30, 32, 34, 37, 40, 44, 47, + 49, 51, 55, 59, 63, 67, 71, 75, 76, 79, + 86, 94, 102, 109, 112, 113, 116, 126, 136, 147, + 157, 166, 179, 183, 192, 193, 194, 196, 197, 199, + 201, 203, 205, 207, 208, 210, 212, 214, 216, 218, + 220, 222, 224, 229, 231, 232, 239, 246, 247, 248, + 249, 251, 252, 254, 255, 258, 260, 263, 265, 267, + 269, 274, 275, 283, 287, 291, 295, 297, 300, 304, + 306, 310, 316, 323, 327, 331, 337, 340, 345, 346, + 352, 354, 356, 362, 367, 373, 378, 384, 391, 397, + 402, 408, 413, 417, 424, 430, 434, 438, 442, 446, + 450, 454, 458, 462, 466, 470, 474, 478, 482, 486, + 489, 492, 495, 498, 501, 504, 507, 510, 514, 517, + 522, 526, 532, 535, 538, 543, 549, 554, 560, 562, + 564, 566, 568, 574, 577, 579, 582, 586, 589, 591, + 593, 595, 597, 599, 601, 606, 612, 614, 616, 620, + 625, 629, 631, 634, 637, 639, 642, 645, 647, 650, + 652, 655, 657, 661, 663, 667, 672, 677, 679, 681, + 683, 685, 689, 692, 696, 699, 701, 703, 705, 706, + 708, 709, 711, 714, 716, 719, 722, 725, 728, 731, + 734, 736, 738, 740 }; /* YYRHS -- A `-1'-separated list of the rules' RHS. */ static const yytype_int16 yyrhs[] = { - 92, 0, -1, 96, 99, -1, 3, 94, 99, 4, - -1, -1, -1, -1, 3, 98, 99, 4, -1, -1, - -1, 99, 116, -1, 99, 100, -1, 115, 103, -1, - 106, -1, 107, -1, 115, 104, -1, 115, 14, -1, - 115, 101, 14, -1, 1, -1, 133, -1, 133, 32, - 133, -1, 133, 33, 133, -1, 133, 30, 133, -1, - 133, 31, 111, -1, 133, 37, 133, -1, 133, 39, - 133, -1, -1, 34, 97, -1, 35, 89, 112, 88, - 97, 102, -1, 32, 89, 94, 112, 88, 97, 102, - -1, 33, 89, 94, 114, 88, 97, 102, -1, 39, - 89, 94, 112, 88, 97, -1, 40, 93, -1, -1, - 36, 93, -1, 115, 30, 89, 94, 110, 88, 108, - 97, 105, -1, 115, 31, 89, 94, 111, 88, 108, - 97, 105, -1, 115, 37, 58, 94, 148, 89, 112, - 88, 97, 105, -1, 115, 37, 150, 89, 94, 112, - 88, 97, 105, -1, 115, 37, 89, 94, 112, 88, - 97, 105, -1, 115, 37, 89, 94, 113, 14, 110, - 14, 108, 113, 88, 97, -1, 115, 93, 105, -1, - 115, 38, 89, 94, 95, 112, 88, 97, -1, -1, - -1, 101, -1, -1, 133, -1, 133, -1, 133, -1, - 109, -1, 111, -1, -1, 24, -1, 118, -1, 121, - -1, 120, -1, 130, -1, 131, -1, 117, -1, 90, - -1, 25, 124, 119, 93, -1, 15, -1, -1, 59, - 122, 125, 126, 127, 129, -1, 26, 122, 125, 126, - 127, 129, -1, -1, -1, -1, 15, -1, -1, 18, - -1, -1, 61, 18, -1, 61, -1, 61, 18, -1, - 61, -1, 93, -1, 14, -1, 28, 15, 15, 14, - -1, -1, 29, 122, 132, 15, 15, 146, 14, -1, - 133, 65, 133, -1, 133, 64, 133, -1, 133, 63, - 133, -1, 134, -1, 134, 67, -1, 134, 67, 143, - -1, 143, -1, 48, 155, 134, -1, 46, 89, 155, - 133, 88, -1, 143, 87, 137, 89, 147, 88, -1, - 143, 87, 137, -1, 16, 155, 146, -1, 17, 155, - 89, 147, 88, -1, 48, 146, -1, 46, 89, 147, - 88, -1, -1, 23, 123, 93, 136, 146, -1, 16, - -1, 150, -1, 154, 3, 133, 14, 4, -1, 150, - 5, 133, 6, -1, 143, 87, 5, 133, 6, -1, - 138, 5, 133, 6, -1, 150, 3, 133, 14, 4, - -1, 143, 87, 3, 133, 14, 4, -1, 138, 3, - 133, 14, 4, -1, 143, 87, 89, 88, -1, 143, - 87, 89, 133, 88, -1, 138, 89, 133, 88, -1, - 138, 89, 88, -1, 89, 133, 88, 5, 133, 6, - -1, 89, 88, 5, 133, 6, -1, 143, 68, 143, - -1, 143, 82, 143, -1, 143, 51, 143, -1, 143, - 52, 143, -1, 143, 76, 143, -1, 143, 49, 143, - -1, 143, 50, 143, -1, 143, 75, 143, -1, 143, - 74, 143, -1, 143, 42, 143, -1, 143, 73, 143, - -1, 143, 72, 143, -1, 143, 71, 143, -1, 143, - 77, 143, -1, 7, 143, -1, 8, 143, -1, 78, - 143, -1, 79, 143, -1, 143, 84, -1, 143, 83, - -1, 86, 143, -1, 85, 143, -1, 5, 133, 6, - -1, 5, 6, -1, 55, 133, 14, 4, -1, 55, - 14, 4, -1, 27, 123, 126, 127, 93, -1, 54, - 143, -1, 54, 93, -1, 54, 15, 89, 88, -1, - 54, 15, 89, 133, 88, -1, 54, 150, 89, 88, - -1, 54, 150, 89, 133, 88, -1, 139, -1, 140, - -1, 141, -1, 142, -1, 143, 69, 143, 70, 143, - -1, 80, 143, -1, 144, -1, 57, 143, -1, 89, - 133, 88, -1, 89, 88, -1, 150, -1, 154, -1, - 152, -1, 151, -1, 153, -1, 138, -1, 151, 5, - 133, 6, -1, 151, 3, 133, 14, 4, -1, 18, - -1, 149, -1, 149, 89, 88, -1, 149, 89, 133, - 88, -1, 56, 15, 146, -1, 41, -1, 41, 143, - -1, 66, 134, -1, 47, -1, 47, 93, -1, 47, - 143, -1, 60, -1, 60, 143, -1, 22, -1, 22, - 143, -1, 44, -1, 44, 89, 88, -1, 21, -1, - 45, 89, 88, -1, 45, 89, 133, 88, -1, 19, - 89, 134, 88, -1, 15, -1, 135, -1, 43, -1, - 58, 145, 128, -1, 58, 145, -1, 89, 133, 88, - -1, 89, 88, -1, 150, -1, 152, -1, 151, -1, - -1, 134, -1, -1, 133, -1, 133, 67, -1, 150, - -1, 13, 155, -1, 9, 155, -1, 10, 155, -1, - 11, 155, -1, 53, 155, -1, 12, 155, -1, 15, - -1, 150, -1, 93, -1, 20, -1 + 94, 0, -1, 98, 101, -1, 3, 96, 101, 4, + -1, -1, -1, -1, 3, 100, 101, 4, -1, -1, + -1, 101, 118, -1, 101, 102, -1, 117, 105, -1, + 108, -1, 109, -1, 117, 106, -1, 117, 14, -1, + 117, 103, 14, -1, 117, 25, -1, 1, -1, 135, + -1, 135, 34, 135, -1, 135, 35, 135, -1, 135, + 32, 135, -1, 135, 33, 113, -1, 135, 39, 135, + -1, 135, 41, 135, -1, -1, 36, 99, -1, 37, + 91, 114, 90, 99, 104, -1, 34, 91, 96, 114, + 90, 99, 104, -1, 35, 91, 96, 116, 90, 99, + 104, -1, 41, 91, 96, 114, 90, 99, -1, 42, + 95, -1, -1, 38, 95, -1, 117, 32, 91, 96, + 112, 90, 110, 99, 107, -1, 117, 33, 91, 96, + 113, 90, 110, 99, 107, -1, 117, 39, 60, 96, + 150, 91, 114, 90, 99, 107, -1, 117, 39, 152, + 91, 96, 114, 90, 99, 107, -1, 117, 39, 91, + 96, 114, 90, 99, 107, -1, 117, 39, 91, 96, + 115, 14, 112, 14, 110, 115, 90, 99, -1, 117, + 95, 107, -1, 117, 40, 91, 96, 97, 114, 90, + 99, -1, -1, -1, 103, -1, -1, 135, -1, 135, + -1, 135, -1, 111, -1, 113, -1, -1, 26, -1, + 120, -1, 123, -1, 122, -1, 132, -1, 133, -1, + 119, -1, 92, -1, 27, 126, 121, 95, -1, 15, + -1, -1, 61, 124, 127, 128, 129, 131, -1, 28, + 124, 127, 128, 129, 131, -1, -1, -1, -1, 15, + -1, -1, 18, -1, -1, 63, 18, -1, 63, -1, + 63, 18, -1, 63, -1, 95, -1, 14, -1, 30, + 15, 15, 14, -1, -1, 31, 124, 134, 15, 15, + 148, 14, -1, 135, 67, 135, -1, 135, 66, 135, + -1, 135, 65, 135, -1, 136, -1, 136, 69, -1, + 136, 69, 145, -1, 145, -1, 50, 157, 136, -1, + 48, 91, 157, 135, 90, -1, 145, 89, 139, 91, + 149, 90, -1, 145, 89, 139, -1, 16, 157, 148, + -1, 17, 157, 91, 149, 90, -1, 50, 148, -1, + 48, 91, 149, 90, -1, -1, 23, 125, 95, 138, + 148, -1, 16, -1, 152, -1, 156, 3, 135, 14, + 4, -1, 152, 5, 135, 6, -1, 145, 89, 5, + 135, 6, -1, 140, 5, 135, 6, -1, 152, 3, + 135, 14, 4, -1, 145, 89, 3, 135, 14, 4, + -1, 140, 3, 135, 14, 4, -1, 145, 89, 91, + 90, -1, 145, 89, 91, 135, 90, -1, 140, 91, + 135, 90, -1, 140, 91, 90, -1, 91, 135, 90, + 5, 135, 6, -1, 91, 90, 5, 135, 6, -1, + 145, 70, 145, -1, 145, 84, 145, -1, 145, 53, + 145, -1, 145, 54, 145, -1, 145, 78, 145, -1, + 145, 51, 145, -1, 145, 52, 145, -1, 145, 77, + 145, -1, 145, 76, 145, -1, 145, 44, 145, -1, + 145, 75, 145, -1, 145, 74, 145, -1, 145, 73, + 145, -1, 145, 79, 145, -1, 7, 145, -1, 8, + 145, -1, 80, 145, -1, 81, 145, -1, 145, 86, + -1, 145, 85, -1, 88, 145, -1, 87, 145, -1, + 5, 135, 6, -1, 5, 6, -1, 57, 135, 14, + 4, -1, 57, 14, 4, -1, 29, 125, 128, 129, + 95, -1, 56, 145, -1, 56, 95, -1, 56, 15, + 91, 90, -1, 56, 15, 91, 135, 90, -1, 56, + 152, 91, 90, -1, 56, 152, 91, 135, 90, -1, + 141, -1, 142, -1, 143, -1, 144, -1, 145, 71, + 145, 72, 145, -1, 82, 145, -1, 146, -1, 59, + 145, -1, 91, 135, 90, -1, 91, 90, -1, 152, + -1, 156, -1, 154, -1, 153, -1, 155, -1, 140, + -1, 153, 5, 135, 6, -1, 153, 3, 135, 14, + 4, -1, 18, -1, 151, -1, 151, 91, 90, -1, + 151, 91, 135, 90, -1, 58, 15, 148, -1, 43, + -1, 43, 145, -1, 68, 136, -1, 49, -1, 49, + 95, -1, 49, 145, -1, 62, -1, 62, 145, -1, + 22, -1, 22, 145, -1, 46, -1, 46, 91, 90, + -1, 21, -1, 47, 91, 90, -1, 47, 91, 135, + 90, -1, 19, 91, 136, 90, -1, 15, -1, 137, + -1, 45, -1, 24, -1, 60, 147, 130, -1, 60, + 147, -1, 91, 135, 90, -1, 91, 90, -1, 152, + -1, 154, -1, 153, -1, -1, 136, -1, -1, 135, + -1, 135, 69, -1, 152, -1, 13, 157, -1, 9, + 157, -1, 10, 157, -1, 11, 157, -1, 55, 157, + -1, 12, 157, -1, 15, -1, 152, -1, 95, -1, + 20, -1 }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { - 0, 140, 140, 146, 156, 160, 164, 170, 180, 185, - 186, 193, 203, 206, 207, 209, 211, 228, 247, 249, - 251, 255, 259, 263, 267, 272, 278, 279, 283, 294, - 302, 313, 316, 322, 323, 330, 343, 355, 366, 376, - 386, 418, 426, 436, 442, 443, 448, 451, 455, 460, - 464, 468, 474, 483, 487, 489, 491, 493, 495, 500, - 504, 510, 524, 525, 529, 542, 565, 571, 576, 581, - 591, 592, 597, 598, 602, 612, 616, 626, 627, 636, - 654, 653, 672, 676, 680, 684, 688, 698, 707, 711, - 716, 723, 732, 738, 744, 752, 756, 763, 762, 773, - 774, 778, 787, 792, 800, 807, 814, 824, 833, 840, - 849, 856, 862, 869, 879, 883, 887, 893, 897, 901, - 905, 909, 913, 917, 929, 933, 937, 941, 951, 955, - 962, 966, 970, 975, 980, 985, 994, 999, 1004, 1010, - 1016, 1027, 1031, 1035, 1047, 1060, 1068, 1080, 1081, 1082, - 1083, 1084, 1089, 1093, 1095, 1099, 1104, 1109, 1111, 1113, - 1115, 1117, 1119, 1121, 1130, 1141, 1143, 1145, 1150, 1163, - 1168, 1173, 1177, 1181, 1185, 1189, 1193, 1197, 1201, 1203, - 1206, 1210, 1216, 1219, 1228, 1234, 1239, 1240, 1241, 1250, - 1258, 1265, 1270, 1275, 1277, 1279, 1284, 1286, 1291, 1292, - 1294, 1309, 1313, 1319, 1325, 1331, 1337, 1343, 1350, 1352, - 1354, 1357 + 0, 141, 141, 147, 157, 161, 165, 171, 181, 186, + 187, 194, 204, 207, 208, 210, 212, 229, 245, 250, + 252, 254, 258, 262, 266, 270, 275, 281, 282, 286, + 297, 305, 316, 319, 325, 326, 333, 346, 358, 369, + 379, 389, 421, 429, 439, 445, 446, 451, 454, 458, + 463, 467, 471, 477, 486, 490, 492, 494, 496, 498, + 503, 507, 513, 527, 528, 532, 545, 568, 574, 579, + 584, 594, 595, 600, 601, 605, 615, 619, 629, 630, + 639, 657, 656, 675, 679, 683, 687, 691, 701, 710, + 714, 719, 726, 735, 741, 747, 755, 759, 766, 765, + 776, 777, 781, 790, 795, 803, 810, 817, 827, 836, + 843, 852, 859, 865, 872, 882, 886, 890, 896, 900, + 904, 908, 912, 916, 920, 932, 936, 940, 944, 954, + 958, 965, 969, 973, 978, 983, 988, 997, 1002, 1007, + 1013, 1019, 1030, 1034, 1038, 1050, 1063, 1071, 1083, 1084, + 1085, 1086, 1087, 1092, 1096, 1098, 1102, 1107, 1112, 1114, + 1116, 1118, 1120, 1122, 1124, 1133, 1144, 1146, 1148, 1153, + 1166, 1171, 1176, 1180, 1184, 1188, 1192, 1196, 1200, 1204, + 1206, 1209, 1213, 1219, 1222, 1231, 1237, 1242, 1243, 1244, + 1250, 1254, 1262, 1269, 1274, 1279, 1281, 1283, 1288, 1290, + 1295, 1296, 1298, 1313, 1317, 1323, 1329, 1335, 1341, 1347, + 1354, 1356, 1358, 1361 }; #endif @@ -200,25 +201,25 @@ static const char *const yytname[] = "$end", "error", "$undefined", "'{'", "'}'", "'['", "']'", "'-'", "'+'", "'$'", "'@'", "'%'", "'*'", "'&'", "';'", "WORD", "METHOD", "FUNCMETH", "THING", "PMFUNC", "PRIVATEREF", "FUNC0SUB", "UNIOPSUB", "LSTOPSUB", - "LABEL", "FORMAT", "SUB", "ANONSUB", "PACKAGE", "USE", "WHILE", "UNTIL", - "IF", "UNLESS", "ELSE", "ELSIF", "CONTINUE", "FOR", "GIVEN", "WHEN", - "DEFAULT", "LOOPEX", "DOTDOT", "YADAYADA", "FUNC0", "FUNC1", "FUNC", - "UNIOP", "LSTOP", "RELOP", "EQOP", "MULOP", "ADDOP", "DOLSHARP", "DO", - "HASHBRACK", "NOAMP", "LOCAL", "MY", "MYSUB", "REQUIRE", "COLONATTR", - "PREC_LOW", "DOROP", "OROP", "ANDOP", "NOTOP", "','", "ASSIGNOP", "'?'", - "':'", "DORDOR", "OROR", "ANDAND", "BITOROP", "BITANDOP", "SHIFTOP", - "MATCHOP", "'!'", "'~'", "REFGEN", "UMINUS", "POWOP", "POSTDEC", - "POSTINC", "PREDEC", "PREINC", "ARROW", "')'", "'('", "PEG", "$accept", - "prog", "block", "remember", "mydefsv", "progstart", "mblock", - "mremember", "lineseq", "line", "sideff", "else", "cond", "case", "cont", - "loop", "switch", "mintro", "nexpr", "texpr", "iexpr", "mexpr", "mnexpr", - "miexpr", "label", "decl", "peg", "format", "formname", "mysubrout", - "subrout", "startsub", "startanonsub", "startformsub", "subname", - "proto", "subattrlist", "myattrlist", "subbody", "package", "use", "$@1", - "expr", "argexpr", "listop", "@2", "method", "subscripted", "termbinop", - "termunop", "anonymous", "termdo", "term", "myattrterm", "myterm", - "listexpr", "listexprcom", "my_scalar", "amper", "scalar", "ary", "hsh", - "arylen", "star", "indirob", 0 + "PLUGEXPR", "PLUGSTMT", "LABEL", "FORMAT", "SUB", "ANONSUB", "PACKAGE", + "USE", "WHILE", "UNTIL", "IF", "UNLESS", "ELSE", "ELSIF", "CONTINUE", + "FOR", "GIVEN", "WHEN", "DEFAULT", "LOOPEX", "DOTDOT", "YADAYADA", + "FUNC0", "FUNC1", "FUNC", "UNIOP", "LSTOP", "RELOP", "EQOP", "MULOP", + "ADDOP", "DOLSHARP", "DO", "HASHBRACK", "NOAMP", "LOCAL", "MY", "MYSUB", + "REQUIRE", "COLONATTR", "PREC_LOW", "DOROP", "OROP", "ANDOP", "NOTOP", + "','", "ASSIGNOP", "'?'", "':'", "DORDOR", "OROR", "ANDAND", "BITOROP", + "BITANDOP", "SHIFTOP", "MATCHOP", "'!'", "'~'", "REFGEN", "UMINUS", + "POWOP", "POSTDEC", "POSTINC", "PREDEC", "PREINC", "ARROW", "')'", "'('", + "PEG", "$accept", "prog", "block", "remember", "mydefsv", "progstart", + "mblock", "mremember", "lineseq", "line", "sideff", "else", "cond", + "case", "cont", "loop", "switch", "mintro", "nexpr", "texpr", "iexpr", + "mexpr", "mnexpr", "miexpr", "label", "decl", "peg", "format", + "formname", "mysubrout", "subrout", "startsub", "startanonsub", + "startformsub", "subname", "proto", "subattrlist", "myattrlist", + "subbody", "package", "use", "$@1", "expr", "argexpr", "listop", "@2", + "method", "subscripted", "termbinop", "termunop", "anonymous", "termdo", + "term", "myattrterm", "myterm", "listexpr", "listexprcom", "my_scalar", + "amper", "scalar", "ary", "hsh", "arylen", "star", "indirob", 0 }; #endif @@ -233,65 +234,65 @@ static const yytype_uint16 yytoknum[] = 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, - 303, 304, 305, 306, 307, 308, 309, 44, 310, 63, - 58, 311, 312, 313, 314, 315, 316, 317, 33, 126, - 318, 319, 320, 321, 322, 323, 324, 325, 41, 40, - 326 + 303, 304, 305, 306, 307, 308, 309, 310, 311, 44, + 312, 63, 58, 313, 314, 315, 316, 317, 318, 319, + 33, 126, 320, 321, 322, 323, 324, 325, 326, 327, + 41, 40, 328 }; # endif /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ static const yytype_uint8 yyr1[] = { - 0, 91, 92, 93, 94, 95, 96, 97, 98, 99, - 99, 99, 100, 100, 100, 100, 100, 100, 101, 101, - 101, 101, 101, 101, 101, 101, 102, 102, 102, 103, - 103, 104, 104, 105, 105, 106, 106, 106, 106, 106, - 106, 106, 107, 108, 109, 109, 110, 110, 111, 112, - 113, 114, 115, 115, 116, 116, 116, 116, 116, 116, - 117, 118, 119, 119, 120, 121, 122, 123, 124, 125, - 126, 126, 127, 127, 127, 128, 128, 129, 129, 130, - 132, 131, 133, 133, 133, 133, 134, 134, 134, 135, - 135, 135, 135, 135, 135, 135, 135, 136, 135, 137, - 137, 138, 138, 138, 138, 138, 138, 138, 138, 138, - 138, 138, 138, 138, 139, 139, 139, 139, 139, 139, - 139, 139, 139, 139, 139, 139, 139, 139, 140, 140, - 140, 140, 140, 140, 140, 140, 141, 141, 141, 141, - 141, 142, 142, 142, 142, 142, 142, 143, 143, 143, - 143, 143, 143, 143, 143, 143, 143, 143, 143, 143, - 143, 143, 143, 143, 143, 143, 143, 143, 143, 143, - 143, 143, 143, 143, 143, 143, 143, 143, 143, 143, - 143, 143, 143, 143, 143, 143, 143, 143, 143, 144, - 144, 145, 145, 145, 145, 145, 146, 146, 147, 147, - 147, 148, 149, 150, 151, 152, 153, 154, 155, 155, - 155, 155 + 0, 93, 94, 95, 96, 97, 98, 99, 100, 101, + 101, 101, 102, 102, 102, 102, 102, 102, 102, 103, + 103, 103, 103, 103, 103, 103, 103, 104, 104, 104, + 105, 105, 106, 106, 107, 107, 108, 108, 108, 108, + 108, 108, 108, 109, 110, 111, 111, 112, 112, 113, + 114, 115, 116, 117, 117, 118, 118, 118, 118, 118, + 118, 119, 120, 121, 121, 122, 123, 124, 125, 126, + 127, 128, 128, 129, 129, 129, 130, 130, 131, 131, + 132, 134, 133, 135, 135, 135, 135, 136, 136, 136, + 137, 137, 137, 137, 137, 137, 137, 137, 138, 137, + 139, 139, 140, 140, 140, 140, 140, 140, 140, 140, + 140, 140, 140, 140, 140, 141, 141, 141, 141, 141, + 141, 141, 141, 141, 141, 141, 141, 141, 141, 142, + 142, 142, 142, 142, 142, 142, 142, 143, 143, 143, + 143, 143, 144, 144, 144, 144, 144, 144, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 146, 146, 147, 147, 147, 147, 147, 148, 148, + 149, 149, 149, 150, 151, 152, 153, 154, 155, 156, + 157, 157, 157, 157 }; /* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ static const yytype_uint8 yyr2[] = { 0, 2, 2, 4, 0, 0, 0, 4, 0, 0, - 2, 2, 2, 1, 1, 2, 2, 3, 1, 1, - 3, 3, 3, 3, 3, 3, 0, 2, 6, 7, - 7, 6, 2, 0, 2, 9, 9, 10, 9, 8, - 12, 3, 8, 0, 0, 1, 0, 1, 1, 1, - 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, - 1, 4, 1, 0, 6, 6, 0, 0, 0, 1, - 0, 1, 0, 2, 1, 2, 1, 1, 1, 4, - 0, 7, 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, 5, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, - 2, 2, 2, 2, 2, 2, 3, 2, 4, 3, - 5, 2, 2, 4, 5, 4, 5, 1, 1, 1, - 1, 5, 2, 1, 2, 3, 2, 1, 1, 1, - 1, 1, 1, 4, 5, 1, 1, 3, 4, 3, - 1, 2, 2, 1, 2, 2, 1, 2, 1, 2, - 1, 3, 1, 3, 4, 4, 1, 1, 1, 3, - 2, 3, 2, 1, 1, 1, 0, 1, 0, 1, - 2, 1, 2, 2, 2, 2, 2, 2, 1, 1, - 1, 1 + 2, 2, 2, 1, 1, 2, 2, 3, 2, 1, + 1, 3, 3, 3, 3, 3, 3, 0, 2, 6, + 7, 7, 6, 2, 0, 2, 9, 9, 10, 9, + 8, 12, 3, 8, 0, 0, 1, 0, 1, 1, + 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 1, 4, 1, 0, 6, 6, 0, 0, 0, + 1, 0, 1, 0, 2, 1, 2, 1, 1, 1, + 4, 0, 7, 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, 5, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, + 2, 2, 2, 2, 2, 2, 2, 3, 2, 4, + 3, 5, 2, 2, 4, 5, 4, 5, 1, 1, + 1, 1, 5, 2, 1, 2, 3, 2, 1, 1, + 1, 1, 1, 1, 4, 5, 1, 1, 3, 4, + 3, 1, 2, 2, 1, 2, 2, 1, 2, 1, + 2, 1, 3, 1, 3, 4, 4, 1, 1, 1, + 1, 3, 2, 3, 2, 1, 1, 1, 0, 1, + 0, 1, 2, 1, 2, 2, 2, 2, 2, 2, + 1, 1, 1, 1 }; /* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state @@ -299,599 +300,601 @@ static const yytype_uint8 yyr2[] = means the default is an error. */ static const yytype_uint8 yydefact[] = { - 6, 0, 9, 1, 52, 53, 68, 66, 0, 66, - 66, 60, 11, 13, 14, 0, 10, 59, 54, 56, - 55, 57, 58, 63, 0, 0, 80, 0, 18, 4, - 0, 0, 0, 0, 0, 0, 0, 0, 16, 186, - 0, 0, 165, 0, 182, 178, 67, 67, 0, 0, - 0, 0, 0, 0, 0, 0, 170, 188, 180, 0, - 0, 173, 196, 0, 0, 0, 0, 0, 0, 176, - 0, 0, 0, 0, 0, 0, 0, 33, 0, 12, - 15, 19, 85, 187, 162, 147, 148, 149, 150, 88, - 153, 166, 157, 160, 159, 161, 158, 62, 0, 69, - 70, 0, 0, 70, 9, 137, 0, 128, 129, 208, - 211, 210, 209, 203, 204, 205, 207, 202, 196, 0, - 0, 179, 0, 70, 4, 4, 4, 4, 4, 4, - 0, 4, 4, 32, 171, 0, 0, 198, 174, 175, - 208, 197, 95, 209, 0, 206, 186, 142, 141, 157, - 0, 0, 196, 154, 0, 190, 193, 195, 194, 177, - 172, 130, 131, 152, 135, 134, 156, 0, 0, 41, - 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 133, - 132, 0, 0, 0, 0, 0, 0, 0, 61, 71, - 72, 79, 0, 72, 52, 136, 93, 198, 0, 97, - 72, 46, 0, 0, 0, 0, 0, 4, 5, 0, - 181, 183, 0, 199, 0, 0, 89, 0, 0, 139, - 0, 169, 192, 0, 76, 189, 0, 155, 34, 22, - 23, 48, 20, 21, 24, 25, 84, 83, 82, 87, - 0, 0, 111, 0, 123, 119, 120, 116, 117, 114, - 0, 126, 125, 124, 122, 121, 118, 127, 115, 0, - 0, 99, 0, 92, 100, 167, 0, 0, 0, 0, - 0, 0, 74, 0, 196, 0, 3, 0, 185, 196, - 0, 0, 47, 0, 0, 49, 51, 0, 0, 201, - 45, 50, 0, 0, 19, 0, 0, 0, 184, 200, - 96, 0, 143, 0, 145, 0, 138, 191, 75, 0, - 0, 0, 104, 110, 0, 0, 0, 108, 0, 198, - 168, 0, 102, 0, 163, 0, 73, 78, 77, 65, - 0, 64, 94, 98, 140, 43, 43, 0, 0, 0, - 0, 46, 0, 0, 0, 90, 144, 146, 113, 0, - 107, 151, 0, 103, 109, 0, 105, 164, 101, 81, - 0, 0, 8, 26, 26, 0, 33, 0, 0, 0, - 31, 112, 106, 91, 33, 33, 9, 0, 0, 29, - 30, 0, 39, 43, 33, 42, 35, 36, 52, 27, - 0, 33, 0, 38, 7, 0, 37, 0, 0, 0, - 26, 40, 28 + 6, 0, 9, 1, 53, 54, 69, 67, 0, 67, + 67, 61, 11, 13, 14, 0, 10, 60, 55, 57, + 56, 58, 59, 64, 0, 0, 81, 0, 19, 4, + 0, 0, 0, 0, 0, 0, 0, 0, 16, 187, + 0, 0, 166, 0, 183, 179, 68, 190, 18, 68, + 0, 0, 0, 0, 0, 0, 0, 0, 171, 189, + 181, 0, 0, 174, 198, 0, 0, 0, 0, 0, + 0, 177, 0, 0, 0, 0, 0, 0, 0, 34, + 0, 12, 15, 20, 86, 188, 163, 148, 149, 150, + 151, 89, 154, 167, 158, 161, 160, 162, 159, 63, + 0, 70, 71, 0, 0, 71, 9, 138, 0, 129, + 130, 210, 213, 212, 211, 205, 206, 207, 209, 204, + 198, 0, 0, 180, 0, 71, 4, 4, 4, 4, + 4, 4, 0, 4, 4, 33, 172, 0, 0, 200, + 175, 176, 210, 199, 96, 211, 0, 208, 187, 143, + 142, 158, 0, 0, 198, 155, 0, 192, 195, 197, + 196, 178, 173, 131, 132, 153, 136, 135, 157, 0, + 0, 42, 17, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 87, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 134, 133, 0, 0, 0, 0, 0, 0, 0, + 62, 72, 73, 80, 0, 73, 53, 137, 94, 200, + 0, 98, 73, 47, 0, 0, 0, 0, 0, 4, + 5, 0, 182, 184, 0, 201, 0, 0, 90, 0, + 0, 140, 0, 170, 194, 0, 77, 191, 0, 156, + 35, 23, 24, 49, 21, 22, 25, 26, 85, 84, + 83, 88, 0, 0, 112, 0, 124, 120, 121, 117, + 118, 115, 0, 127, 126, 125, 123, 122, 119, 128, + 116, 0, 0, 100, 0, 93, 101, 168, 0, 0, + 0, 0, 0, 0, 75, 0, 198, 0, 3, 0, + 186, 198, 0, 0, 48, 0, 0, 50, 52, 0, + 0, 203, 46, 51, 0, 0, 20, 0, 0, 0, + 185, 202, 97, 0, 144, 0, 146, 0, 139, 193, + 76, 0, 0, 0, 105, 111, 0, 0, 0, 109, + 0, 200, 169, 0, 103, 0, 164, 0, 74, 79, + 78, 66, 0, 65, 95, 99, 141, 44, 44, 0, + 0, 0, 0, 47, 0, 0, 0, 91, 145, 147, + 114, 0, 108, 152, 0, 104, 110, 0, 106, 165, + 102, 82, 0, 0, 8, 27, 27, 0, 34, 0, + 0, 0, 32, 113, 107, 92, 34, 34, 9, 0, + 0, 30, 31, 0, 40, 44, 34, 43, 36, 37, + 53, 28, 0, 34, 0, 39, 7, 0, 38, 0, + 0, 0, 27, 41, 29 }; /* YYDEFGOTO[NTERM-NUM]. */ static const yytype_int16 yydefgoto[] = { - -1, 1, 111, 104, 316, 2, 383, 396, 4, 12, - 310, 399, 79, 80, 169, 13, 14, 380, 311, 301, - 250, 304, 313, 307, 15, 16, 17, 18, 98, 19, - 20, 24, 122, 23, 100, 210, 293, 245, 349, 21, - 22, 102, 305, 82, 83, 299, 283, 84, 85, 86, - 87, 88, 89, 90, 155, 142, 234, 308, 91, 92, - 93, 94, 95, 96, 113 + -1, 1, 113, 106, 318, 2, 385, 398, 4, 12, + 312, 401, 81, 82, 171, 13, 14, 382, 313, 303, + 252, 306, 315, 309, 15, 16, 17, 18, 100, 19, + 20, 24, 124, 23, 102, 212, 295, 247, 351, 21, + 22, 104, 307, 84, 85, 301, 285, 86, 87, 88, + 89, 90, 91, 92, 157, 144, 236, 310, 93, 94, + 95, 96, 97, 98, 115 }; /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing STATE-NUM. */ -#define YYPACT_NINF -344 +#define YYPACT_NINF -373 static const yytype_int16 yypact[] = { - -344, 39, -344, -344, 47, -344, -344, -344, 28, -344, - -344, -344, -344, -344, -344, 295, -344, -344, -344, -344, - -344, -344, -344, 34, 59, 65, -344, 59, -344, -344, - 877, 1723, 1723, 351, 351, 351, 351, 351, -344, -344, - 351, 351, -344, -5, -344, 1723, -344, -344, 3, 7, - 22, 52, 35, 81, 88, 226, 1723, -344, 96, 121, - 148, 646, 561, 351, 731, 960, 223, 1723, 19, 1723, - 1723, 1723, 1723, 1723, 1723, 1723, 1043, 100, 242, -344, - -344, 1004, 199, -344, 14, -344, -344, -344, -344, 1897, - -344, 179, 135, 200, -344, -344, 266, -344, 226, -344, - 255, 260, 264, 255, -344, -344, 80, 507, 507, -344, - -344, -344, -344, -344, -344, -344, -344, -344, 1723, 192, - 1723, 422, 226, 255, -344, -344, -344, -344, -344, -344, - 197, -344, -344, -344, 1897, 203, 1128, 561, -344, 422, - 1784, 199, -344, 793, 1723, -344, 205, -344, 422, 21, - 288, -6, 1723, 422, 1213, 234, -344, -344, -344, 422, - 199, 507, 507, 507, 131, 131, 292, -28, 226, -344, - -344, 1723, 1723, 1723, 1723, 1723, 1723, 1723, 1723, 1723, - 1723, 1723, 1723, 1298, 1723, 1723, 1723, 1723, 1723, 1723, - 1723, 1723, 1723, 1723, 1723, 1723, 1723, 1723, 1723, -344, - -344, 11, 1383, 1723, 1723, 1723, 1723, 1723, -344, -344, - 238, -344, 286, 238, 90, -344, -344, 1723, -42, -344, - 238, 1723, 1723, 1723, 1723, 311, 391, -344, -344, 1723, - -344, -344, -10, 119, 233, 1723, 199, 1468, 1553, -344, - 319, -344, -344, 133, 312, -344, 1723, 324, -344, 220, - -344, 220, 220, 220, 220, 220, 272, 272, -344, 1897, - 26, 89, -344, 323, 1975, 909, 718, 678, 280, 1897, - 1858, 462, 462, 548, 632, 862, 379, 507, 507, 1723, - 1723, -344, 1638, 256, -344, -344, 352, 69, 163, 194, - 170, 225, 326, 42, 1723, 42, -344, 259, -344, 1723, - 226, 268, 220, 270, 271, 220, -344, 277, 283, -344, - -344, -344, 289, 362, 390, 1723, 1723, 290, -344, -344, - -344, 460, -344, 522, -344, 607, -344, -344, -344, 198, - 1723, 375, -344, -344, 1723, 305, 207, -344, 633, 1723, - -344, 378, -344, 381, -344, 385, -344, -344, -344, -344, - 369, -344, -344, -344, -344, -344, -344, 388, 388, 1723, - 388, 1723, 306, 307, 388, -344, -344, -344, -344, 213, - -344, 1936, 389, -344, -344, 331, -344, -344, -344, -344, - 388, 388, -344, 182, 182, 336, 100, 411, 388, 388, - -344, -344, -344, -344, 100, 100, -344, 388, 337, -344, - -344, 388, -344, -344, 100, -344, -344, -344, 122, -344, - 1723, 100, 474, -344, -344, 340, -344, 345, 388, 388, - 182, -344, -344 + -373, 28, -373, -373, 3, -373, -373, -373, 65, -373, + -373, -373, -373, -373, -373, 320, -373, -373, -373, -373, + -373, -373, -373, 74, 75, 84, -373, 75, -373, -373, + 899, 1765, 1765, 378, 378, 378, 378, 378, -373, -373, + 378, 378, -373, -67, -373, 1765, -373, -373, -373, -373, + -51, -24, -8, -5, 9, 37, 76, 147, 1765, -373, + 89, 92, 97, 666, 579, 378, 753, 984, 141, 1765, + 12, 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1069, 137, + 167, -373, -373, 1067, 115, -373, 48, -373, -373, -373, + -373, 1907, -373, 104, 93, 110, -373, -373, 207, -373, + 147, -373, 200, 209, 214, 200, -373, -373, 140, 68, + 68, -373, -373, -373, -373, -373, -373, -373, -373, -373, + 1765, 135, 1765, 230, 147, 200, -373, -373, -373, -373, + -373, -373, 146, -373, -373, -373, 1907, 151, 1156, 579, + -373, 230, 1825, 115, -373, 813, 1765, -373, 169, -373, + 230, 52, 260, 120, 1765, 230, 1243, 202, -373, -373, + -373, 230, 115, 68, 68, 68, 59, 59, 263, 319, + 147, -373, -373, 1765, 1765, 1765, 1765, 1765, 1765, 1765, + 1765, 1765, 1765, 1765, 1765, 1330, 1765, 1765, 1765, 1765, + 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1765, + 1765, -373, -373, 88, 1417, 1765, 1765, 1765, 1765, 1765, + -373, -373, 212, -373, 259, 212, 81, -373, -373, 1765, + -43, -373, 212, 1765, 1765, 1765, 1765, 270, 405, -373, + -373, 1765, -373, -373, 366, 71, 195, 1765, 115, 1504, + 1591, -373, 288, -373, -373, 461, 276, -373, 1765, 290, + -373, 224, -373, 224, 224, 224, 224, 224, 231, 231, + -373, 1907, 221, 149, -373, 540, 1985, 970, 884, 525, + 217, 1907, 1868, 478, 478, 566, 652, 931, 393, 68, + 68, 1765, 1765, -373, 1678, 216, -373, -373, 627, 245, + 165, 291, 196, 306, 282, 24, 1765, 24, -373, 223, + -373, 1765, 147, 228, 224, 232, 234, 224, -373, 250, + 255, -373, -373, -373, 257, 336, 404, 1765, 1765, 261, + -373, -373, -373, 653, -373, 714, -373, 724, -373, -373, + -373, 206, 1765, 360, -373, -373, 1765, 375, 211, -373, + 727, 1765, -373, 370, -373, 379, -373, 386, -373, -373, + -373, -373, 377, -373, -373, -373, -373, -373, -373, 391, + 391, 1765, 391, 1765, 305, 307, 391, -373, -373, -373, + -373, 215, -373, 1946, 392, -373, -373, 313, -373, -373, + -373, -373, 391, 391, -373, 25, 25, 314, 137, 411, + 391, 391, -373, -373, -373, -373, 137, 137, -373, 391, + 339, -373, -373, 391, -373, -373, 137, -373, -373, -373, + 90, -373, 1765, 137, 490, -373, -373, 315, -373, 345, + 391, 391, 25, -373, -373 }; /* YYPGOTO[NTERM-NUM]. */ static const yytype_int16 yypgoto[] = { - -344, -344, -13, -62, -344, -344, 1505, -344, -103, -344, - 426, -343, -344, -344, 147, -344, -344, -335, -344, 82, - 8, -217, 30, -344, -344, -344, -344, -344, -344, -344, - -344, 215, 403, -344, 425, -21, -116, -344, 164, -344, - -344, -344, -15, -39, -344, -344, -344, -344, -344, -344, - -344, -344, 56, -344, -344, -100, -204, -344, -344, -30, - 392, 396, -344, -344, 138 + -373, -373, 2, -52, -373, -373, -163, -373, -105, -373, + 429, -372, -373, -373, 128, -373, -373, -349, -373, 86, + -48, -212, 43, -373, -373, -373, -373, -373, -373, -373, + -373, 61, 409, -373, 432, -59, -183, -373, 171, -373, + -373, -373, -15, -62, -373, -373, -373, -373, -373, -373, + -373, -373, 56, -373, -373, -100, -206, -373, -373, -29, + 396, 406, -373, -373, 8 }; /* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If positive, shift that token. If negative, reduce the rule which number is the opposite. If zero, do what YYDEFACT says. If YYTABLE_NINF, syntax error. */ -#define YYTABLE_NINF -187 +#define YYTABLE_NINF -188 static const yytype_int16 yytable[] = { - 81, 214, 77, 112, 112, 112, 112, 112, 240, 312, - 112, 112, 317, 297, 279, 106, 280, 181, 216, 182, - 33, 381, 130, 141, 203, 180, 204, 281, 33, 34, - 35, 160, 143, 112, 149, 177, 178, 179, 156, 3, - 331, 400, 133, 25, 33, 29, 298, -2, 138, 97, - 151, 147, 241, 177, 178, 179, 347, 177, 178, 179, - 247, 167, 221, 222, 223, 224, 225, 226, 412, 228, - 229, 5, 6, 7, 99, 8, 9, 422, 318, 141, - 101, 218, 213, 341, 120, 208, 215, 107, 108, 177, - 178, 179, 124, 128, 296, 332, 125, 295, 362, 363, - 282, 121, 220, 183, 300, 236, 10, 143, 154, 219, - 238, 126, 134, 141, 5, 6, 7, 139, 8, 9, - 148, 232, 233, 153, 129, 159, 414, 161, 162, 163, - 164, 165, 177, 178, 179, 375, 168, 11, 203, 243, - 204, 127, 385, 177, 178, 179, 5, 6, 7, 10, - 8, 9, 177, 178, 179, 248, 249, 251, 252, 253, - 254, 255, 256, 257, 258, 315, 260, 261, 263, 342, - 131, 284, 114, 115, 116, 117, 344, 132, 118, 119, - 11, 10, 177, 178, 179, 135, 319, 286, 287, 288, - 289, 290, 291, 415, 350, 309, 177, 178, 179, 353, - 144, 145, 233, 205, 368, 206, 302, 251, 343, 251, - 136, 314, 11, 373, -187, -187, 397, 398, 201, 391, - 321, 327, 323, 325, 26, 27, 177, 178, 179, 29, - 303, 329, 306, 177, 178, 179, 259, 137, 152, 345, - 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, - 274, 275, 276, 277, 278, 141, 170, 177, 178, 179, - 141, 177, 178, 179, 335, 336, 180, 338, 202, 207, - 177, 178, 179, 209, 211, 235, 177, 178, 179, 212, - 348, 217, 348, 177, 178, 179, 227, 354, 177, 178, - 179, 230, 239, 408, 237, 244, 28, 246, 29, 292, - 30, 294, 31, 32, 33, 34, 35, 36, 37, 38, - 39, 40, 41, 42, 43, 369, 44, 45, 46, 372, - 33, 320, 47, 326, 233, 48, 49, 50, 51, 330, - 328, 187, 52, 53, 54, 55, 56, 179, 57, 58, - 59, 60, 61, 62, 346, 339, 302, 352, 63, 64, - 65, 66, 67, 68, 29, 69, 355, 197, 356, 357, - 33, 70, 198, 199, 200, 358, 109, 201, 177, 178, - 179, 110, 359, 71, 72, 73, 361, 360, 364, 370, - 74, 75, 376, 379, 76, 377, 177, 178, 179, 378, - 371, 382, 28, 392, 388, 389, 30, 81, 31, 32, - 33, 34, 35, 36, 37, -44, 39, 40, 41, 42, - 43, 333, 44, 45, 46, 177, 178, 179, 47, 393, - 171, 172, 173, 174, 401, 403, 410, 175, 418, 176, - 187, 188, 56, 419, 57, 58, 59, 60, 61, 62, - 340, 78, 417, 387, 63, 64, 65, 66, 67, 68, - 123, 69, 103, 177, 178, 179, 197, 70, 0, 351, - 157, 198, 199, 200, 158, 0, 201, 0, 0, 71, - 72, 73, 0, 187, 188, 28, 74, 75, -49, 30, - 76, 31, 32, 33, 34, 35, 36, 37, 0, 39, - 40, 41, 42, 43, 0, 44, 45, 46, 196, 197, - 0, 47, 0, 0, 198, 199, 200, 0, 0, 201, - 0, 185, 186, 187, 188, 56, 0, 57, 58, 59, - 60, 61, 62, 177, 178, 179, 0, 63, 64, 65, - 66, 67, 68, 402, 69, 193, 194, 195, 196, 197, - 70, 406, 407, 0, 198, 199, 200, 0, 365, 201, - 0, 413, 71, 72, 73, 0, 0, 0, 416, 74, - 75, 0, -44, 76, 29, 0, 30, 0, 31, 32, - 33, 34, 35, 36, 37, 0, 140, 40, 41, 42, - 43, 110, 44, 45, 46, 177, 178, 179, 47, 198, - 199, 200, 0, 0, 201, 0, 0, 185, 186, 187, - 188, 0, 56, 0, 57, 58, 59, 60, 61, 62, - 366, 0, 0, 0, 63, 64, 65, 66, 67, 68, - 0, 69, 194, 195, 196, 197, 0, 70, 0, 0, - 198, 199, 200, 0, 0, 201, 0, 0, 0, 71, - 72, 73, 0, 0, 0, 0, 74, 75, 0, 29, - 76, 30, 0, 31, 32, 33, 34, 35, 36, 37, + 83, 216, 143, -2, 114, 114, 114, 114, 114, 383, + 162, 114, 114, 299, 402, 108, 314, 79, 33, 319, + 218, 33, 34, 35, 122, 132, 182, 29, 3, 5, + 6, 7, 297, 8, 9, 145, 114, 151, 349, 302, + 126, 158, 116, 117, 118, 119, 215, 300, 120, 121, + 424, 183, 153, 184, 243, 205, 414, 206, 143, 135, + 220, 399, 400, 169, 10, 140, 222, 127, 149, 130, + 26, 27, 146, 147, 223, 224, 225, 226, 227, 228, + 25, 230, 231, 128, 238, 298, 129, 109, 110, 99, + 101, 281, 143, 282, 416, 11, 205, 33, 206, 103, + 131, 123, 210, 156, 283, 364, 365, 5, 6, 7, + 145, 8, 9, 207, 136, 208, 5, 6, 7, 141, + 8, 9, 150, 234, 235, 155, 221, 161, 133, 163, + 164, 165, 166, 167, 242, 377, 179, 180, 181, 185, + 321, 245, 10, 240, -188, -188, 217, 237, 203, 387, + 29, 10, 200, 201, 202, 334, 154, 203, 251, 253, + 254, 255, 256, 257, 258, 259, 260, 134, 262, 263, + 265, 344, 250, 11, 286, 170, 305, 317, 308, 284, + 137, 172, 11, 138, 182, 179, 180, 181, 139, 288, + 289, 290, 291, 292, 293, 204, 352, 386, 311, 388, + 417, 355, 346, 392, 235, 179, 180, 181, 304, 253, + 209, 253, 370, 316, 179, 180, 181, 375, 211, 396, + 397, 393, 323, 213, 325, 327, 219, 406, 407, 214, + 179, 180, 181, 331, 143, 333, 411, 229, 261, 143, + 413, 232, 266, 267, 268, 269, 270, 271, 272, 273, + 274, 275, 276, 277, 278, 279, 280, 422, 423, 343, + 239, 179, 180, 181, 241, 246, 337, 338, 248, 340, + 189, 179, 180, 181, 296, 294, 179, 180, 181, 33, + 179, 180, 181, 189, 190, 322, 179, 180, 181, 179, + 180, 181, 328, 410, 330, 332, 199, 350, 181, 350, + 348, 200, 201, 202, 356, 345, 203, 341, 198, 199, + 179, 180, 181, 354, 200, 201, 202, 371, 357, 203, + 347, 28, 358, 29, 359, 30, 235, 31, 32, 33, + 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, + 360, 44, 45, 46, 47, 48, 361, 362, 304, 49, + 363, 366, 50, 51, 52, 53, 179, 180, 181, 54, + 55, 56, 57, 58, 372, 59, 60, 61, 62, 63, + 64, 179, 180, 181, 378, 65, 66, 67, 68, 69, + 70, 29, 71, 379, 179, 180, 181, 33, 72, 374, + 380, 381, 373, 111, 384, 390, 394, 391, 112, 83, + 73, 74, 75, 395, 403, 420, 28, 76, 77, 249, + 30, 78, 31, 32, 33, 34, 35, 36, 37, -45, + 39, 40, 41, 42, 43, 405, 44, 45, 46, 47, + 412, 179, 180, 181, 49, 421, 173, 174, 175, 176, + 179, 180, 181, 177, 80, 178, 189, 190, 58, 389, + 59, 60, 61, 62, 63, 64, 320, 419, 125, 105, + 65, 66, 67, 68, 69, 70, 159, 71, 353, 179, + 180, 181, 199, 72, 0, 0, 160, 200, 201, 202, + 0, 0, 203, 0, 0, 73, 74, 75, 0, 0, + 0, 28, 76, 77, -50, 30, 78, 31, 32, 33, + 34, 35, 36, 37, 0, 39, 40, 41, 42, 43, + 0, 44, 45, 46, 47, 0, 404, 0, 0, 49, + 0, 0, 0, 0, 408, 409, 179, 180, 181, 187, + 188, 189, 190, 58, 415, 59, 60, 61, 62, 63, + 64, 418, 0, 0, 0, 65, 66, 67, 68, 69, + 70, 329, 71, 195, 196, 197, 198, 199, 72, 0, + 0, 0, 200, 201, 202, 0, 0, 203, 0, 0, + 73, 74, 75, 0, 0, 0, 0, 76, 77, 0, + -45, 78, 29, 0, 30, 0, 31, 32, 33, 34, + 35, 36, 37, 0, 142, 40, 41, 42, 43, 112, + 44, 45, 46, 47, 199, 179, 180, 181, 49, 200, + 201, 202, 0, 0, 203, 0, 0, 187, 188, 189, + 190, 0, 58, 0, 59, 60, 61, 62, 63, 64, + 335, 0, 0, 0, 65, 66, 67, 68, 69, 70, + 0, 71, 196, 197, 198, 199, 0, 72, 0, 0, + 200, 201, 202, 0, 0, 203, 0, 0, 0, 73, + 74, 75, 0, 0, 0, 0, 76, 77, 0, 29, + 78, 30, 0, 31, 32, 33, 34, 35, 36, 37, 0, 39, 40, 41, 42, 43, 0, 44, 45, 46, - 177, 178, 179, 47, 0, 0, 0, 0, 0, 0, - 0, 185, 186, 187, 188, 0, 0, 56, 0, 57, - 58, 59, 60, 61, 62, 367, 177, 178, 179, 63, - 64, 65, 66, 67, 68, 0, 69, 195, 196, 197, - 0, 0, 70, 0, 198, 199, 200, 0, 0, 201, - 0, 374, 0, 0, 71, 72, 73, 0, 0, 0, - 0, 74, 75, 0, 29, 76, 30, 0, 31, 32, - 33, 34, 35, 36, 37, 0, 146, 40, 41, 42, - 43, 0, 44, 45, 46, 197, 0, 0, 47, 0, - 198, 199, 200, 0, 0, 201, 0, 185, -187, 187, - 188, 0, 56, 0, 57, 58, 59, 60, 61, 62, - 0, 0, 0, 0, 63, 64, 65, 66, 67, 68, - 0, 69, 0, 0, 196, 197, 203, 70, 204, -157, - 198, 199, 200, 0, 0, 201, 0, -157, 0, 71, - 72, 73, 0, 0, 0, 0, 74, 75, 0, 0, - 76, 0, 0, -157, -157, -157, -157, 0, 0, 0, - -157, 0, -157, 0, 0, -157, 0, 0, 0, 0, - 0, 0, -157, -157, -157, -157, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, -157, -157, -157, 0, - -157, -157, -157, -157, -157, -157, -157, -157, -157, -157, - -157, 0, 0, 0, 0, -157, -157, -157, 0, 0, - -157, -157, 30, 105, 31, 32, 33, 34, 35, 36, - 37, 0, 39, 40, 41, 42, 43, 0, 44, 45, - 46, 0, 0, 0, 47, 0, 0, 0, 0, 0, - 0, 185, 186, 187, 188, 0, 0, 0, 56, 0, - 57, 58, 59, 60, 61, 62, 0, 0, 0, 0, - 63, 64, 65, 66, 67, 68, 0, 69, 196, 197, - 0, 0, 0, 70, 198, 199, 200, 0, 0, 201, - 0, 0, 0, 0, 0, 71, 72, 73, -187, 0, - 187, 188, 74, 75, 0, 30, 76, 31, 32, 33, - 34, 35, 36, 37, 150, 39, 40, 41, 42, 43, - 0, 44, 45, 46, 0, 196, 197, 47, 0, 0, - 0, 198, 199, 200, 0, 0, 201, 0, 0, 0, - 0, 56, 0, 57, 58, 59, 60, 61, 62, 0, - 0, 0, 0, 63, 64, 65, 66, 67, 68, 0, - 69, 0, 0, 0, 0, 0, 70, 0, 0, 0, - 0, 0, 0, 0, 171, 172, 173, 174, 71, 72, - 73, 175, 0, 176, 0, 74, 75, 0, 30, 76, + 47, 0, 179, 180, 181, 49, 0, 0, 0, 0, + 0, 0, 0, 187, 188, 189, 190, 0, 0, 58, + 0, 59, 60, 61, 62, 63, 64, 342, 179, 180, + 181, 65, 66, 67, 68, 69, 70, 0, 71, 197, + 198, 199, 0, 0, 72, 0, 200, 201, 202, 0, + 0, 203, 0, 367, 0, 0, 73, 74, 75, 0, + 0, 0, 0, 76, 77, 0, 29, 78, 30, 0, + 31, 32, 33, 34, 35, 36, 37, 0, 148, 40, + 41, 42, 43, 0, 44, 45, 46, 47, 0, 179, + 180, 181, 49, 0, 0, 0, 0, 0, 0, 179, + 180, 181, 179, 180, 181, 0, 58, 0, 59, 60, + 61, 62, 63, 64, 368, 0, 0, 0, 65, 66, + 67, 68, 69, 70, 369, 71, 205, 376, 206, -158, + 0, 72, 0, 0, 0, 0, 0, -158, 0, 0, + 0, 0, 0, 73, 74, 75, 0, 0, 0, 0, + 76, 77, 0, 0, 78, -158, -158, -158, -158, 0, + 0, 0, -158, 0, -158, 0, 0, -158, 0, 0, + 0, 0, 0, 0, -158, -158, -158, -158, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, -158, -158, + -158, 0, -158, -158, -158, -158, -158, -158, -158, -158, + -158, -158, -158, 0, 0, 0, 0, -158, -158, -158, + 0, 0, -158, -158, 30, 107, 31, 32, 33, 34, + 35, 36, 37, 0, 39, 40, 41, 42, 43, 0, + 44, 45, 46, 47, 0, 0, 0, 0, 49, 0, + 0, 0, 0, 0, 0, 187, -188, 189, 190, 0, + 0, 0, 58, 0, 59, 60, 61, 62, 63, 64, + 0, 0, 0, 0, 65, 66, 67, 68, 69, 70, + 0, 71, 198, 199, 0, 0, 0, 72, 200, 201, + 202, 0, 0, 203, 0, 0, 0, 0, 0, 73, + 74, 75, 187, 188, 189, 190, 76, 77, 0, 30, + 78, 31, 32, 33, 34, 35, 36, 37, 152, 39, + 40, 41, 42, 43, 0, 44, 45, 46, 47, 198, + 199, 0, 0, 49, 0, 200, 201, 202, 0, 0, + 203, -188, 0, 189, 190, 0, 0, 58, 0, 59, + 60, 61, 62, 63, 64, 0, 0, 0, 0, 65, + 66, 67, 68, 69, 70, 0, 71, 0, 198, 199, + 0, 0, 72, 0, 200, 201, 202, 0, 0, 203, + 0, 0, 0, 0, 73, 74, 75, 0, 0, 0, + 0, 76, 77, 0, 30, 78, 31, 32, 33, 34, + 35, 36, 37, 0, 39, 40, 41, 42, 43, 0, + 44, 45, 46, 47, 0, 0, 0, 0, 49, 173, + 174, 175, 176, 0, 0, 0, 177, 0, 178, 0, + 0, 0, 58, 0, 59, 60, 61, 62, 63, 64, + 0, 0, 0, 0, 65, 66, 67, 68, 69, 70, + 0, 71, 179, 180, 181, 0, 0, 72, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 73, + 74, 75, 0, 0, 0, 0, 76, 77, 0, 168, + 78, 30, 0, 31, 32, 33, 34, 35, 36, 37, + 0, 39, 40, 41, 42, 43, 0, 44, 45, 46, + 47, 0, 0, 0, 0, 49, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 58, + 0, 59, 60, 61, 62, 63, 64, 0, 0, 0, + 0, 65, 66, 67, 68, 69, 70, 0, 71, 0, + 0, 0, 0, 0, 72, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 73, 74, 75, 0, + 0, 0, 0, 76, 77, 0, 233, 78, 30, 0, 31, 32, 33, 34, 35, 36, 37, 0, 39, 40, - 41, 42, 43, 0, 44, 45, 46, 177, 178, 179, - 47, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 56, 0, 57, 58, 59, 60, - 61, 62, 0, 0, 0, 0, 63, 64, 65, 66, - 67, 68, 0, 69, 0, 0, 0, 0, 0, 70, + 41, 42, 43, 0, 44, 45, 46, 47, 0, 0, + 0, 0, 49, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 58, 0, 59, 60, + 61, 62, 63, 64, 0, 0, 0, 0, 65, 66, + 67, 68, 69, 70, 0, 71, 0, 0, 0, 0, + 0, 72, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 73, 74, 75, 0, 0, 0, 0, + 76, 77, 0, 244, 78, 30, 0, 31, 32, 33, + 34, 35, 36, 37, 0, 39, 40, 41, 42, 43, + 0, 44, 45, 46, 47, 0, 0, 0, 0, 49, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 71, 72, 73, 0, 0, 0, 0, 74, 75, - 0, 166, 76, 30, 0, 31, 32, 33, 34, 35, - 36, 37, 0, 39, 40, 41, 42, 43, 0, 44, - 45, 46, 0, 0, 0, 47, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 56, - 0, 57, 58, 59, 60, 61, 62, 0, 0, 0, - 0, 63, 64, 65, 66, 67, 68, 0, 69, 0, - 0, 0, 0, 0, 70, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 71, 72, 73, 0, - 0, 0, 0, 74, 75, 0, 231, 76, 30, 0, - 31, 32, 33, 34, 35, 36, 37, 0, 39, 40, - 41, 42, 43, 0, 44, 45, 46, 0, 0, 0, - 47, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 56, 0, 57, 58, 59, 60, - 61, 62, 0, 0, 0, 0, 63, 64, 65, 66, - 67, 68, 0, 69, 0, 0, 0, 0, 0, 70, + 0, 0, 0, 58, 0, 59, 60, 61, 62, 63, + 64, 0, 0, 0, 0, 65, 66, 67, 68, 69, + 70, 0, 71, 0, 0, 0, 0, 0, 72, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 71, 72, 73, 0, 0, 0, 0, 74, 75, - 0, 242, 76, 30, 0, 31, 32, 33, 34, 35, - 36, 37, 0, 39, 40, 41, 42, 43, 0, 44, - 45, 46, 0, 0, 0, 47, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 56, - 0, 57, 58, 59, 60, 61, 62, 0, 0, 0, - 0, 63, 64, 65, 66, 67, 68, 0, 69, 0, - 0, 0, 0, 0, 70, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 71, 72, 73, 0, - 0, 0, 0, 74, 75, 0, 262, 76, 30, 0, - 31, 32, 33, 34, 35, 36, 37, 0, 39, 40, - 41, 42, 43, 0, 44, 45, 46, 0, 0, 0, - 47, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 56, 0, 57, 58, 59, 60, - 61, 62, 0, 0, 0, 0, 63, 64, 65, 66, - 67, 68, 0, 69, 0, 0, 0, 0, 0, 70, + 73, 74, 75, 0, 0, 0, 0, 76, 77, 0, + 264, 78, 30, 0, 31, 32, 33, 34, 35, 36, + 37, 0, 39, 40, 41, 42, 43, 0, 44, 45, + 46, 47, 0, 0, 0, 0, 49, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 71, 72, 73, 0, 0, 0, 0, 74, 75, - 0, 285, 76, 30, 0, 31, 32, 33, 34, 35, - 36, 37, 0, 39, 40, 41, 42, 43, 0, 44, - 45, 46, 0, 0, 0, 47, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 56, - 0, 57, 58, 59, 60, 61, 62, 0, 0, 0, - 0, 63, 64, 65, 66, 67, 68, 0, 69, 0, - 0, 0, 0, 0, 70, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 71, 72, 73, 0, - 0, 0, 0, 74, 75, 0, 322, 76, 30, 0, - 31, 32, 33, 34, 35, 36, 37, 0, 39, 40, - 41, 42, 43, 0, 44, 45, 46, 0, 0, 0, - 47, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 56, 0, 57, 58, 59, 60, - 61, 62, 0, 0, 0, 0, 63, 64, 65, 66, - 67, 68, 0, 69, 0, 0, 0, 0, 0, 70, + 58, 0, 59, 60, 61, 62, 63, 64, 0, 0, + 0, 0, 65, 66, 67, 68, 69, 70, 0, 71, + 0, 0, 0, 0, 0, 72, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 73, 74, 75, + 0, 0, 0, 0, 76, 77, 0, 287, 78, 30, + 0, 31, 32, 33, 34, 35, 36, 37, 0, 39, + 40, 41, 42, 43, 0, 44, 45, 46, 47, 0, + 0, 0, 0, 49, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 58, 0, 59, + 60, 61, 62, 63, 64, 0, 0, 0, 0, 65, + 66, 67, 68, 69, 70, 0, 71, 0, 0, 0, + 0, 0, 72, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 73, 74, 75, 0, 0, 0, + 0, 76, 77, 0, 324, 78, 30, 0, 31, 32, + 33, 34, 35, 36, 37, 0, 39, 40, 41, 42, + 43, 0, 44, 45, 46, 47, 0, 0, 0, 0, + 49, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 58, 0, 59, 60, 61, 62, + 63, 64, 0, 0, 0, 0, 65, 66, 67, 68, + 69, 70, 0, 71, 0, 0, 0, 0, 0, 72, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 71, 72, 73, 0, 0, 0, 0, 74, 75, - 0, 324, 76, 30, 0, 31, 32, 33, 34, 35, + 0, 73, 74, 75, 0, 0, 0, 0, 76, 77, + 0, 326, 78, 30, 0, 31, 32, 33, 34, 35, 36, 37, 0, 39, 40, 41, 42, 43, 0, 44, - 45, 46, 0, 0, 0, 47, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 56, - 0, 57, 58, 59, 60, 61, 62, 0, 0, 0, - 0, 63, 64, 65, 66, 67, 68, 0, 69, 0, - 0, 0, 0, 0, 70, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 71, 72, 73, 0, - 0, 0, 0, 74, 75, 0, 337, 76, 30, 0, - 31, 32, 33, 34, 35, 36, 37, 0, 39, 40, - 41, 42, 43, 0, 44, 45, 46, 0, 0, 0, - 47, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 56, 0, 57, 58, 59, 60, - 61, 62, 0, 0, 0, 0, 63, 64, 65, 66, - 67, 68, 0, 69, 0, 0, 0, 0, 0, 70, - -186, 0, 0, 0, 0, 0, 0, 0, -186, 0, - 0, 71, 72, 73, 0, 0, 0, 0, 74, 75, - 0, 0, 76, 0, -186, -186, -186, -186, 0, 0, - 0, -186, 0, -186, 0, 0, -186, 0, 0, 0, - 0, 0, 0, -186, -186, -186, -186, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, -186, -186, -186, - 0, -186, -186, -186, -186, -186, -186, -186, -186, -186, - -186, -186, 0, 384, 0, 386, -186, -186, -186, 390, - 0, -186, -186, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 394, 395, 0, 0, 0, - 0, 0, 0, 404, 405, 0, 0, 0, 0, 0, - 184, 0, 409, 0, 0, 0, 411, 185, 186, 187, - 188, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 420, 421, 0, 189, 190, 334, 191, - 192, 193, 194, 195, 196, 197, 0, 0, 0, 184, - 198, 199, 200, 0, 0, 201, 185, 186, 187, 188, + 45, 46, 47, 0, 0, 0, 0, 49, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 189, 190, 0, 191, 192, - 193, 194, 195, 196, 197, 0, 0, 0, 184, 198, - 199, 200, 0, 0, 201, 185, 186, 187, 188, 0, + 0, 58, 0, 59, 60, 61, 62, 63, 64, 0, + 0, 0, 0, 65, 66, 67, 68, 69, 70, 0, + 71, 0, 0, 0, 0, 0, 72, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 73, 74, + 75, 0, 0, 0, 0, 76, 77, 0, 339, 78, + 30, 0, 31, 32, 33, 34, 35, 36, 37, 0, + 39, 40, 41, 42, 43, 0, 44, 45, 46, 47, + 0, 0, 0, 0, 49, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 58, 0, + 59, 60, 61, 62, 63, 64, 0, 0, 0, 0, + 65, 66, 67, 68, 69, 70, 0, 71, 0, 0, + 0, -187, 0, 72, 0, 0, 0, 0, 0, -187, + 0, 0, 0, 0, 0, 73, 74, 75, 0, 0, + 0, 0, 76, 77, 0, 0, 78, -187, -187, -187, + -187, 0, 0, 0, -187, 0, -187, 0, 0, -187, + 0, 0, 0, 0, 0, 0, -187, -187, -187, -187, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 190, 0, 191, 192, 193, - 194, 195, 196, 197, 0, 0, 0, -187, 198, 199, - 200, 0, 0, 201, 185, 186, 187, 188, 0, 0, + -187, -187, -187, 0, -187, -187, -187, -187, -187, -187, + -187, -187, -187, -187, -187, 0, 0, 0, 0, -187, + -187, -187, 186, 0, -187, -187, 0, 0, 0, 187, + 188, 189, 190, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 191, 192, + 336, 193, 194, 195, 196, 197, 198, 199, 0, 0, + 0, 186, 200, 201, 202, 0, 0, 203, 187, 188, + 189, 190, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 191, 192, 0, + 193, 194, 195, 196, 197, 198, 199, 0, 0, 0, + 186, 200, 201, 202, 0, 0, 203, 187, 188, 189, + 190, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 192, 0, 193, + 194, 195, 196, 197, 198, 199, 0, 0, 0, -188, + 200, 201, 202, 0, 0, 203, 187, 188, 189, 190, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 191, 192, 193, 194, - 195, 196, 197, 0, 0, 0, 0, 198, 199, 200, - 0, 0, 201 + 0, 0, 0, 0, 0, 0, 0, 0, 193, 194, + 195, 196, 197, 198, 199, 0, 0, 0, 0, 200, + 201, 202, 0, 0, 203 }; static const yytype_int16 yycheck[] = { - 15, 104, 15, 33, 34, 35, 36, 37, 14, 226, - 40, 41, 229, 217, 3, 30, 5, 3, 118, 5, - 9, 356, 52, 62, 3, 67, 5, 16, 9, 10, - 11, 70, 62, 63, 64, 63, 64, 65, 68, 0, - 14, 384, 55, 15, 9, 3, 88, 0, 61, 15, - 65, 64, 152, 63, 64, 65, 14, 63, 64, 65, - 88, 76, 124, 125, 126, 127, 128, 129, 403, 131, - 132, 24, 25, 26, 15, 28, 29, 420, 88, 118, - 15, 120, 103, 14, 89, 98, 6, 31, 32, 63, - 64, 65, 89, 58, 4, 6, 89, 213, 315, 316, - 89, 45, 123, 89, 220, 144, 59, 137, 89, 122, - 89, 89, 56, 152, 24, 25, 26, 61, 28, 29, - 64, 136, 137, 67, 89, 69, 4, 71, 72, 73, - 74, 75, 63, 64, 65, 339, 36, 90, 3, 154, - 5, 89, 359, 63, 64, 65, 24, 25, 26, 59, - 28, 29, 63, 64, 65, 168, 171, 172, 173, 174, - 175, 176, 177, 178, 179, 227, 181, 182, 183, 6, - 89, 201, 34, 35, 36, 37, 6, 89, 40, 41, - 90, 59, 63, 64, 65, 89, 67, 202, 203, 204, - 205, 206, 207, 410, 294, 225, 63, 64, 65, 299, - 62, 63, 217, 3, 6, 5, 221, 222, 14, 224, - 89, 226, 90, 6, 83, 84, 34, 35, 87, 6, - 235, 88, 237, 238, 9, 10, 63, 64, 65, 3, - 222, 246, 224, 63, 64, 65, 180, 89, 15, 14, - 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, - 194, 195, 196, 197, 198, 294, 14, 63, 64, 65, - 299, 63, 64, 65, 279, 280, 67, 282, 89, 3, - 63, 64, 65, 18, 14, 137, 63, 64, 65, 15, - 293, 89, 295, 63, 64, 65, 89, 300, 63, 64, - 65, 88, 4, 396, 89, 61, 1, 5, 3, 61, - 5, 15, 7, 8, 9, 10, 11, 12, 13, 14, - 15, 16, 17, 18, 19, 330, 21, 22, 23, 14, - 9, 88, 27, 4, 339, 30, 31, 32, 33, 5, - 18, 51, 37, 38, 39, 40, 41, 65, 43, 44, - 45, 46, 47, 48, 18, 89, 361, 88, 53, 54, - 55, 56, 57, 58, 3, 60, 88, 77, 88, 88, - 9, 66, 82, 83, 84, 88, 15, 87, 63, 64, - 65, 20, 89, 78, 79, 80, 14, 88, 88, 4, - 85, 86, 4, 14, 89, 4, 63, 64, 65, 4, - 334, 3, 1, 4, 88, 88, 5, 412, 7, 8, - 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, - 19, 88, 21, 22, 23, 63, 64, 65, 27, 88, - 30, 31, 32, 33, 88, 14, 89, 37, 88, 39, - 51, 52, 41, 88, 43, 44, 45, 46, 47, 48, - 88, 15, 412, 361, 53, 54, 55, 56, 57, 58, - 47, 60, 27, 63, 64, 65, 77, 66, -1, 295, - 68, 82, 83, 84, 68, -1, 87, -1, -1, 78, - 79, 80, -1, 51, 52, 1, 85, 86, 88, 5, - 89, 7, 8, 9, 10, 11, 12, 13, -1, 15, - 16, 17, 18, 19, -1, 21, 22, 23, 76, 77, - -1, 27, -1, -1, 82, 83, 84, -1, -1, 87, - -1, 49, 50, 51, 52, 41, -1, 43, 44, 45, - 46, 47, 48, 63, 64, 65, -1, 53, 54, 55, - 56, 57, 58, 386, 60, 73, 74, 75, 76, 77, - 66, 394, 395, -1, 82, 83, 84, -1, 88, 87, - -1, 404, 78, 79, 80, -1, -1, -1, 411, 85, - 86, -1, 88, 89, 3, -1, 5, -1, 7, 8, - 9, 10, 11, 12, 13, -1, 15, 16, 17, 18, - 19, 20, 21, 22, 23, 63, 64, 65, 27, 82, - 83, 84, -1, -1, 87, -1, -1, 49, 50, 51, - 52, -1, 41, -1, 43, 44, 45, 46, 47, 48, - 88, -1, -1, -1, 53, 54, 55, 56, 57, 58, - -1, 60, 74, 75, 76, 77, -1, 66, -1, -1, - 82, 83, 84, -1, -1, 87, -1, -1, -1, 78, - 79, 80, -1, -1, -1, -1, 85, 86, -1, 3, - 89, 5, -1, 7, 8, 9, 10, 11, 12, 13, - -1, 15, 16, 17, 18, 19, -1, 21, 22, 23, - 63, 64, 65, 27, -1, -1, -1, -1, -1, -1, - -1, 49, 50, 51, 52, -1, -1, 41, -1, 43, - 44, 45, 46, 47, 48, 88, 63, 64, 65, 53, - 54, 55, 56, 57, 58, -1, 60, 75, 76, 77, - -1, -1, 66, -1, 82, 83, 84, -1, -1, 87, - -1, 88, -1, -1, 78, 79, 80, -1, -1, -1, - -1, 85, 86, -1, 3, 89, 5, -1, 7, 8, - 9, 10, 11, 12, 13, -1, 15, 16, 17, 18, - 19, -1, 21, 22, 23, 77, -1, -1, 27, -1, - 82, 83, 84, -1, -1, 87, -1, 49, 50, 51, - 52, -1, 41, -1, 43, 44, 45, 46, 47, 48, - -1, -1, -1, -1, 53, 54, 55, 56, 57, 58, - -1, 60, -1, -1, 76, 77, 3, 66, 5, 6, - 82, 83, 84, -1, -1, 87, -1, 14, -1, 78, - 79, 80, -1, -1, -1, -1, 85, 86, -1, -1, - 89, -1, -1, 30, 31, 32, 33, -1, -1, -1, - 37, -1, 39, -1, -1, 42, -1, -1, -1, -1, - -1, -1, 49, 50, 51, 52, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 63, 64, 65, -1, - 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, - 77, -1, -1, -1, -1, 82, 83, 84, -1, -1, - 87, 88, 5, 6, 7, 8, 9, 10, 11, 12, - 13, -1, 15, 16, 17, 18, 19, -1, 21, 22, - 23, -1, -1, -1, 27, -1, -1, -1, -1, -1, - -1, 49, 50, 51, 52, -1, -1, -1, 41, -1, - 43, 44, 45, 46, 47, 48, -1, -1, -1, -1, - 53, 54, 55, 56, 57, 58, -1, 60, 76, 77, - -1, -1, -1, 66, 82, 83, 84, -1, -1, 87, - -1, -1, -1, -1, -1, 78, 79, 80, 49, -1, - 51, 52, 85, 86, -1, 5, 89, 7, 8, 9, + 15, 106, 64, 0, 33, 34, 35, 36, 37, 358, + 72, 40, 41, 219, 386, 30, 228, 15, 9, 231, + 120, 9, 10, 11, 91, 54, 69, 3, 0, 26, + 27, 28, 215, 30, 31, 64, 65, 66, 14, 222, + 91, 70, 34, 35, 36, 37, 105, 90, 40, 41, + 422, 3, 67, 5, 154, 3, 405, 5, 120, 57, + 122, 36, 37, 78, 61, 63, 125, 91, 66, 60, + 9, 10, 64, 65, 126, 127, 128, 129, 130, 131, + 15, 133, 134, 91, 146, 4, 91, 31, 32, 15, + 15, 3, 154, 5, 4, 92, 3, 9, 5, 15, + 91, 45, 100, 91, 16, 317, 318, 26, 27, 28, + 139, 30, 31, 3, 58, 5, 26, 27, 28, 63, + 30, 31, 66, 138, 139, 69, 124, 71, 91, 73, + 74, 75, 76, 77, 14, 341, 65, 66, 67, 91, + 69, 156, 61, 91, 85, 86, 6, 139, 89, 361, + 3, 61, 84, 85, 86, 6, 15, 89, 173, 174, + 175, 176, 177, 178, 179, 180, 181, 91, 183, 184, + 185, 6, 170, 92, 203, 38, 224, 229, 226, 91, + 91, 14, 92, 91, 69, 65, 66, 67, 91, 204, + 205, 206, 207, 208, 209, 91, 296, 360, 227, 362, + 412, 301, 6, 366, 219, 65, 66, 67, 223, 224, + 3, 226, 6, 228, 65, 66, 67, 6, 18, 382, + 383, 6, 237, 14, 239, 240, 91, 390, 391, 15, + 65, 66, 67, 248, 296, 14, 399, 91, 182, 301, + 403, 90, 186, 187, 188, 189, 190, 191, 192, 193, + 194, 195, 196, 197, 198, 199, 200, 420, 421, 14, + 91, 65, 66, 67, 4, 63, 281, 282, 5, 284, + 53, 65, 66, 67, 15, 63, 65, 66, 67, 9, + 65, 66, 67, 53, 54, 90, 65, 66, 67, 65, + 66, 67, 4, 398, 18, 5, 79, 295, 67, 297, + 18, 84, 85, 86, 302, 14, 89, 91, 78, 79, + 65, 66, 67, 90, 84, 85, 86, 332, 90, 89, + 14, 1, 90, 3, 90, 5, 341, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, - -1, 21, 22, 23, -1, 76, 77, 27, -1, -1, - -1, 82, 83, 84, -1, -1, 87, -1, -1, -1, - -1, 41, -1, 43, 44, 45, 46, 47, 48, -1, - -1, -1, -1, 53, 54, 55, 56, 57, 58, -1, - 60, -1, -1, -1, -1, -1, 66, -1, -1, -1, - -1, -1, -1, -1, 30, 31, 32, 33, 78, 79, - 80, 37, -1, 39, -1, 85, 86, -1, 5, 89, + 90, 21, 22, 23, 24, 25, 91, 90, 363, 29, + 14, 90, 32, 33, 34, 35, 65, 66, 67, 39, + 40, 41, 42, 43, 4, 45, 46, 47, 48, 49, + 50, 65, 66, 67, 4, 55, 56, 57, 58, 59, + 60, 3, 62, 4, 65, 66, 67, 9, 68, 14, + 4, 14, 336, 15, 3, 90, 4, 90, 20, 414, + 80, 81, 82, 90, 90, 90, 1, 87, 88, 90, + 5, 91, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, 18, 19, 14, 21, 22, 23, 24, + 91, 65, 66, 67, 29, 90, 32, 33, 34, 35, + 65, 66, 67, 39, 15, 41, 53, 54, 43, 363, + 45, 46, 47, 48, 49, 50, 90, 414, 49, 27, + 55, 56, 57, 58, 59, 60, 70, 62, 297, 65, + 66, 67, 79, 68, -1, -1, 70, 84, 85, 86, + -1, -1, 89, -1, -1, 80, 81, 82, -1, -1, + -1, 1, 87, 88, 90, 5, 91, 7, 8, 9, + 10, 11, 12, 13, -1, 15, 16, 17, 18, 19, + -1, 21, 22, 23, 24, -1, 388, -1, -1, 29, + -1, -1, -1, -1, 396, 397, 65, 66, 67, 51, + 52, 53, 54, 43, 406, 45, 46, 47, 48, 49, + 50, 413, -1, -1, -1, 55, 56, 57, 58, 59, + 60, 90, 62, 75, 76, 77, 78, 79, 68, -1, + -1, -1, 84, 85, 86, -1, -1, 89, -1, -1, + 80, 81, 82, -1, -1, -1, -1, 87, 88, -1, + 90, 91, 3, -1, 5, -1, 7, 8, 9, 10, + 11, 12, 13, -1, 15, 16, 17, 18, 19, 20, + 21, 22, 23, 24, 79, 65, 66, 67, 29, 84, + 85, 86, -1, -1, 89, -1, -1, 51, 52, 53, + 54, -1, 43, -1, 45, 46, 47, 48, 49, 50, + 90, -1, -1, -1, 55, 56, 57, 58, 59, 60, + -1, 62, 76, 77, 78, 79, -1, 68, -1, -1, + 84, 85, 86, -1, -1, 89, -1, -1, -1, 80, + 81, 82, -1, -1, -1, -1, 87, 88, -1, 3, + 91, 5, -1, 7, 8, 9, 10, 11, 12, 13, + -1, 15, 16, 17, 18, 19, -1, 21, 22, 23, + 24, -1, 65, 66, 67, 29, -1, -1, -1, -1, + -1, -1, -1, 51, 52, 53, 54, -1, -1, 43, + -1, 45, 46, 47, 48, 49, 50, 90, 65, 66, + 67, 55, 56, 57, 58, 59, 60, -1, 62, 77, + 78, 79, -1, -1, 68, -1, 84, 85, 86, -1, + -1, 89, -1, 90, -1, -1, 80, 81, 82, -1, + -1, -1, -1, 87, 88, -1, 3, 91, 5, -1, 7, 8, 9, 10, 11, 12, 13, -1, 15, 16, - 17, 18, 19, -1, 21, 22, 23, 63, 64, 65, - 27, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 41, -1, 43, 44, 45, 46, - 47, 48, -1, -1, -1, -1, 53, 54, 55, 56, - 57, 58, -1, 60, -1, -1, -1, -1, -1, 66, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 78, 79, 80, -1, -1, -1, -1, 85, 86, - -1, 88, 89, 5, -1, 7, 8, 9, 10, 11, - 12, 13, -1, 15, 16, 17, 18, 19, -1, 21, - 22, 23, -1, -1, -1, 27, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, 43, 44, 45, 46, 47, 48, -1, -1, -1, - -1, 53, 54, 55, 56, 57, 58, -1, 60, -1, - -1, -1, -1, -1, 66, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 78, 79, 80, -1, - -1, -1, -1, 85, 86, -1, 88, 89, 5, -1, + 17, 18, 19, -1, 21, 22, 23, 24, -1, 65, + 66, 67, 29, -1, -1, -1, -1, -1, -1, 65, + 66, 67, 65, 66, 67, -1, 43, -1, 45, 46, + 47, 48, 49, 50, 90, -1, -1, -1, 55, 56, + 57, 58, 59, 60, 90, 62, 3, 90, 5, 6, + -1, 68, -1, -1, -1, -1, -1, 14, -1, -1, + -1, -1, -1, 80, 81, 82, -1, -1, -1, -1, + 87, 88, -1, -1, 91, 32, 33, 34, 35, -1, + -1, -1, 39, -1, 41, -1, -1, 44, -1, -1, + -1, -1, -1, -1, 51, 52, 53, 54, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 65, 66, + 67, -1, 69, 70, 71, 72, 73, 74, 75, 76, + 77, 78, 79, -1, -1, -1, -1, 84, 85, 86, + -1, -1, 89, 90, 5, 6, 7, 8, 9, 10, + 11, 12, 13, -1, 15, 16, 17, 18, 19, -1, + 21, 22, 23, 24, -1, -1, -1, -1, 29, -1, + -1, -1, -1, -1, -1, 51, 52, 53, 54, -1, + -1, -1, 43, -1, 45, 46, 47, 48, 49, 50, + -1, -1, -1, -1, 55, 56, 57, 58, 59, 60, + -1, 62, 78, 79, -1, -1, -1, 68, 84, 85, + 86, -1, -1, 89, -1, -1, -1, -1, -1, 80, + 81, 82, 51, 52, 53, 54, 87, 88, -1, 5, + 91, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, -1, 21, 22, 23, 24, 78, + 79, -1, -1, 29, -1, 84, 85, 86, -1, -1, + 89, 51, -1, 53, 54, -1, -1, 43, -1, 45, + 46, 47, 48, 49, 50, -1, -1, -1, -1, 55, + 56, 57, 58, 59, 60, -1, 62, -1, 78, 79, + -1, -1, 68, -1, 84, 85, 86, -1, -1, 89, + -1, -1, -1, -1, 80, 81, 82, -1, -1, -1, + -1, 87, 88, -1, 5, 91, 7, 8, 9, 10, + 11, 12, 13, -1, 15, 16, 17, 18, 19, -1, + 21, 22, 23, 24, -1, -1, -1, -1, 29, 32, + 33, 34, 35, -1, -1, -1, 39, -1, 41, -1, + -1, -1, 43, -1, 45, 46, 47, 48, 49, 50, + -1, -1, -1, -1, 55, 56, 57, 58, 59, 60, + -1, 62, 65, 66, 67, -1, -1, 68, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 80, + 81, 82, -1, -1, -1, -1, 87, 88, -1, 90, + 91, 5, -1, 7, 8, 9, 10, 11, 12, 13, + -1, 15, 16, 17, 18, 19, -1, 21, 22, 23, + 24, -1, -1, -1, -1, 29, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 43, + -1, 45, 46, 47, 48, 49, 50, -1, -1, -1, + -1, 55, 56, 57, 58, 59, 60, -1, 62, -1, + -1, -1, -1, -1, 68, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 80, 81, 82, -1, + -1, -1, -1, 87, 88, -1, 90, 91, 5, -1, 7, 8, 9, 10, 11, 12, 13, -1, 15, 16, - 17, 18, 19, -1, 21, 22, 23, -1, -1, -1, - 27, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 41, -1, 43, 44, 45, 46, - 47, 48, -1, -1, -1, -1, 53, 54, 55, 56, - 57, 58, -1, 60, -1, -1, -1, -1, -1, 66, + 17, 18, 19, -1, 21, 22, 23, 24, -1, -1, + -1, -1, 29, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 43, -1, 45, 46, + 47, 48, 49, 50, -1, -1, -1, -1, 55, 56, + 57, 58, 59, 60, -1, 62, -1, -1, -1, -1, + -1, 68, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 80, 81, 82, -1, -1, -1, -1, + 87, 88, -1, 90, 91, 5, -1, 7, 8, 9, + 10, 11, 12, 13, -1, 15, 16, 17, 18, 19, + -1, 21, 22, 23, 24, -1, -1, -1, -1, 29, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 78, 79, 80, -1, -1, -1, -1, 85, 86, - -1, 88, 89, 5, -1, 7, 8, 9, 10, 11, - 12, 13, -1, 15, 16, 17, 18, 19, -1, 21, - 22, 23, -1, -1, -1, 27, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, 43, 44, 45, 46, 47, 48, -1, -1, -1, - -1, 53, 54, 55, 56, 57, 58, -1, 60, -1, - -1, -1, -1, -1, 66, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 78, 79, 80, -1, - -1, -1, -1, 85, 86, -1, 88, 89, 5, -1, - 7, 8, 9, 10, 11, 12, 13, -1, 15, 16, - 17, 18, 19, -1, 21, 22, 23, -1, -1, -1, - 27, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 41, -1, 43, 44, 45, 46, - 47, 48, -1, -1, -1, -1, 53, 54, 55, 56, - 57, 58, -1, 60, -1, -1, -1, -1, -1, 66, + -1, -1, -1, 43, -1, 45, 46, 47, 48, 49, + 50, -1, -1, -1, -1, 55, 56, 57, 58, 59, + 60, -1, 62, -1, -1, -1, -1, -1, 68, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 78, 79, 80, -1, -1, -1, -1, 85, 86, - -1, 88, 89, 5, -1, 7, 8, 9, 10, 11, - 12, 13, -1, 15, 16, 17, 18, 19, -1, 21, - 22, 23, -1, -1, -1, 27, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, 43, 44, 45, 46, 47, 48, -1, -1, -1, - -1, 53, 54, 55, 56, 57, 58, -1, 60, -1, - -1, -1, -1, -1, 66, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 78, 79, 80, -1, - -1, -1, -1, 85, 86, -1, 88, 89, 5, -1, - 7, 8, 9, 10, 11, 12, 13, -1, 15, 16, - 17, 18, 19, -1, 21, 22, 23, -1, -1, -1, - 27, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 41, -1, 43, 44, 45, 46, - 47, 48, -1, -1, -1, -1, 53, 54, 55, 56, - 57, 58, -1, 60, -1, -1, -1, -1, -1, 66, + 80, 81, 82, -1, -1, -1, -1, 87, 88, -1, + 90, 91, 5, -1, 7, 8, 9, 10, 11, 12, + 13, -1, 15, 16, 17, 18, 19, -1, 21, 22, + 23, 24, -1, -1, -1, -1, 29, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 78, 79, 80, -1, -1, -1, -1, 85, 86, - -1, 88, 89, 5, -1, 7, 8, 9, 10, 11, + 43, -1, 45, 46, 47, 48, 49, 50, -1, -1, + -1, -1, 55, 56, 57, 58, 59, 60, -1, 62, + -1, -1, -1, -1, -1, 68, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 80, 81, 82, + -1, -1, -1, -1, 87, 88, -1, 90, 91, 5, + -1, 7, 8, 9, 10, 11, 12, 13, -1, 15, + 16, 17, 18, 19, -1, 21, 22, 23, 24, -1, + -1, -1, -1, 29, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 43, -1, 45, + 46, 47, 48, 49, 50, -1, -1, -1, -1, 55, + 56, 57, 58, 59, 60, -1, 62, -1, -1, -1, + -1, -1, 68, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 80, 81, 82, -1, -1, -1, + -1, 87, 88, -1, 90, 91, 5, -1, 7, 8, + 9, 10, 11, 12, 13, -1, 15, 16, 17, 18, + 19, -1, 21, 22, 23, 24, -1, -1, -1, -1, + 29, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 43, -1, 45, 46, 47, 48, + 49, 50, -1, -1, -1, -1, 55, 56, 57, 58, + 59, 60, -1, 62, -1, -1, -1, -1, -1, 68, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 80, 81, 82, -1, -1, -1, -1, 87, 88, + -1, 90, 91, 5, -1, 7, 8, 9, 10, 11, 12, 13, -1, 15, 16, 17, 18, 19, -1, 21, - 22, 23, -1, -1, -1, 27, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, 43, 44, 45, 46, 47, 48, -1, -1, -1, - -1, 53, 54, 55, 56, 57, 58, -1, 60, -1, - -1, -1, -1, -1, 66, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 78, 79, 80, -1, - -1, -1, -1, 85, 86, -1, 88, 89, 5, -1, - 7, 8, 9, 10, 11, 12, 13, -1, 15, 16, - 17, 18, 19, -1, 21, 22, 23, -1, -1, -1, - 27, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 41, -1, 43, 44, 45, 46, - 47, 48, -1, -1, -1, -1, 53, 54, 55, 56, - 57, 58, -1, 60, -1, -1, -1, -1, -1, 66, - 6, -1, -1, -1, -1, -1, -1, -1, 14, -1, - -1, 78, 79, 80, -1, -1, -1, -1, 85, 86, - -1, -1, 89, -1, 30, 31, 32, 33, -1, -1, - -1, 37, -1, 39, -1, -1, 42, -1, -1, -1, - -1, -1, -1, 49, 50, 51, 52, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 63, 64, 65, - -1, 67, 68, 69, 70, 71, 72, 73, 74, 75, - 76, 77, -1, 358, -1, 360, 82, 83, 84, 364, - -1, 87, 88, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 380, 381, -1, -1, -1, - -1, -1, -1, 388, 389, -1, -1, -1, -1, -1, - 42, -1, 397, -1, -1, -1, 401, 49, 50, 51, - 52, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 418, 419, -1, 68, 69, 70, 71, - 72, 73, 74, 75, 76, 77, -1, -1, -1, 42, - 82, 83, 84, -1, -1, 87, 49, 50, 51, 52, + 22, 23, 24, -1, -1, -1, -1, 29, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 68, 69, -1, 71, 72, - 73, 74, 75, 76, 77, -1, -1, -1, 42, 82, - 83, 84, -1, -1, 87, 49, 50, 51, 52, -1, + -1, 43, -1, 45, 46, 47, 48, 49, 50, -1, + -1, -1, -1, 55, 56, 57, 58, 59, 60, -1, + 62, -1, -1, -1, -1, -1, 68, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 80, 81, + 82, -1, -1, -1, -1, 87, 88, -1, 90, 91, + 5, -1, 7, 8, 9, 10, 11, 12, 13, -1, + 15, 16, 17, 18, 19, -1, 21, 22, 23, 24, + -1, -1, -1, -1, 29, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 43, -1, + 45, 46, 47, 48, 49, 50, -1, -1, -1, -1, + 55, 56, 57, 58, 59, 60, -1, 62, -1, -1, + -1, 6, -1, 68, -1, -1, -1, -1, -1, 14, + -1, -1, -1, -1, -1, 80, 81, 82, -1, -1, + -1, -1, 87, 88, -1, -1, 91, 32, 33, 34, + 35, -1, -1, -1, 39, -1, 41, -1, -1, 44, + -1, -1, -1, -1, -1, -1, 51, 52, 53, 54, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 69, -1, 71, 72, 73, - 74, 75, 76, 77, -1, -1, -1, 42, 82, 83, - 84, -1, -1, 87, 49, 50, 51, 52, -1, -1, + 65, 66, 67, -1, 69, 70, 71, 72, 73, 74, + 75, 76, 77, 78, 79, -1, -1, -1, -1, 84, + 85, 86, 44, -1, 89, 90, -1, -1, -1, 51, + 52, 53, 54, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 70, 71, + 72, 73, 74, 75, 76, 77, 78, 79, -1, -1, + -1, 44, 84, 85, 86, -1, -1, 89, 51, 52, + 53, 54, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 70, 71, -1, + 73, 74, 75, 76, 77, 78, 79, -1, -1, -1, + 44, 84, 85, 86, -1, -1, 89, 51, 52, 53, + 54, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 71, -1, 73, + 74, 75, 76, 77, 78, 79, -1, -1, -1, 44, + 84, 85, 86, -1, -1, 89, 51, 52, 53, 54, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 71, 72, 73, 74, - 75, 76, 77, -1, -1, -1, -1, 82, 83, 84, - -1, -1, 87 + -1, -1, -1, -1, -1, -1, -1, -1, 73, 74, + 75, 76, 77, 78, 79, -1, -1, -1, -1, 84, + 85, 86, -1, -1, 89 }; /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing symbol of state STATE-NUM. */ static const yytype_uint8 yystos[] = { - 0, 92, 96, 0, 99, 24, 25, 26, 28, 29, - 59, 90, 100, 106, 107, 115, 116, 117, 118, 120, - 121, 130, 131, 124, 122, 15, 122, 122, 1, 3, + 0, 94, 98, 0, 101, 26, 27, 28, 30, 31, + 61, 92, 102, 108, 109, 117, 118, 119, 120, 122, + 123, 132, 133, 126, 124, 15, 124, 124, 1, 3, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 21, 22, 23, 27, 30, 31, - 32, 33, 37, 38, 39, 40, 41, 43, 44, 45, - 46, 47, 48, 53, 54, 55, 56, 57, 58, 60, - 66, 78, 79, 80, 85, 86, 89, 93, 101, 103, - 104, 133, 134, 135, 138, 139, 140, 141, 142, 143, - 144, 149, 150, 151, 152, 153, 154, 15, 119, 15, - 125, 15, 132, 125, 94, 6, 133, 143, 143, 15, - 20, 93, 150, 155, 155, 155, 155, 155, 155, 155, - 89, 143, 123, 123, 89, 89, 89, 89, 58, 89, - 150, 89, 89, 93, 143, 89, 89, 89, 93, 143, - 15, 134, 146, 150, 155, 155, 15, 93, 143, 150, - 14, 133, 15, 143, 89, 145, 150, 151, 152, 143, - 134, 143, 143, 143, 143, 143, 88, 133, 36, 105, - 14, 30, 31, 32, 33, 37, 39, 63, 64, 65, - 67, 3, 5, 89, 42, 49, 50, 51, 52, 68, - 69, 71, 72, 73, 74, 75, 76, 77, 82, 83, - 84, 87, 89, 3, 5, 3, 5, 3, 93, 18, - 126, 14, 15, 126, 99, 6, 146, 89, 134, 93, - 126, 94, 94, 94, 94, 94, 94, 89, 94, 94, - 88, 88, 133, 133, 147, 155, 134, 89, 89, 4, - 14, 146, 88, 133, 61, 128, 5, 88, 93, 133, - 111, 133, 133, 133, 133, 133, 133, 133, 133, 143, - 133, 133, 88, 133, 143, 143, 143, 143, 143, 143, - 143, 143, 143, 143, 143, 143, 143, 143, 143, 3, - 5, 16, 89, 137, 150, 88, 133, 133, 133, 133, - 133, 133, 61, 127, 15, 127, 4, 147, 88, 136, - 127, 110, 133, 111, 112, 133, 111, 114, 148, 150, - 101, 109, 112, 113, 133, 94, 95, 112, 88, 67, - 88, 133, 88, 133, 88, 133, 4, 88, 18, 133, - 5, 14, 6, 88, 70, 133, 133, 88, 133, 89, - 88, 14, 6, 14, 6, 14, 18, 14, 93, 129, - 146, 129, 88, 146, 93, 88, 88, 88, 88, 89, - 88, 14, 112, 112, 88, 88, 88, 88, 6, 133, - 4, 143, 14, 6, 88, 147, 4, 4, 4, 14, - 108, 108, 3, 97, 97, 112, 97, 110, 88, 88, - 97, 6, 4, 88, 97, 97, 98, 34, 35, 102, - 102, 88, 105, 14, 97, 97, 105, 105, 99, 97, - 89, 97, 108, 105, 4, 112, 105, 113, 88, 88, - 97, 97, 102 + 16, 17, 18, 19, 21, 22, 23, 24, 25, 29, + 32, 33, 34, 35, 39, 40, 41, 42, 43, 45, + 46, 47, 48, 49, 50, 55, 56, 57, 58, 59, + 60, 62, 68, 80, 81, 82, 87, 88, 91, 95, + 103, 105, 106, 135, 136, 137, 140, 141, 142, 143, + 144, 145, 146, 151, 152, 153, 154, 155, 156, 15, + 121, 15, 127, 15, 134, 127, 96, 6, 135, 145, + 145, 15, 20, 95, 152, 157, 157, 157, 157, 157, + 157, 157, 91, 145, 125, 125, 91, 91, 91, 91, + 60, 91, 152, 91, 91, 95, 145, 91, 91, 91, + 95, 145, 15, 136, 148, 152, 157, 157, 15, 95, + 145, 152, 14, 135, 15, 145, 91, 147, 152, 153, + 154, 145, 136, 145, 145, 145, 145, 145, 90, 135, + 38, 107, 14, 32, 33, 34, 35, 39, 41, 65, + 66, 67, 69, 3, 5, 91, 44, 51, 52, 53, + 54, 70, 71, 73, 74, 75, 76, 77, 78, 79, + 84, 85, 86, 89, 91, 3, 5, 3, 5, 3, + 95, 18, 128, 14, 15, 128, 101, 6, 148, 91, + 136, 95, 128, 96, 96, 96, 96, 96, 96, 91, + 96, 96, 90, 90, 135, 135, 149, 157, 136, 91, + 91, 4, 14, 148, 90, 135, 63, 130, 5, 90, + 95, 135, 113, 135, 135, 135, 135, 135, 135, 135, + 135, 145, 135, 135, 90, 135, 145, 145, 145, 145, + 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, + 145, 3, 5, 16, 91, 139, 152, 90, 135, 135, + 135, 135, 135, 135, 63, 129, 15, 129, 4, 149, + 90, 138, 129, 112, 135, 113, 114, 135, 113, 116, + 150, 152, 103, 111, 114, 115, 135, 96, 97, 114, + 90, 69, 90, 135, 90, 135, 90, 135, 4, 90, + 18, 135, 5, 14, 6, 90, 72, 135, 135, 90, + 135, 91, 90, 14, 6, 14, 6, 14, 18, 14, + 95, 131, 148, 131, 90, 148, 95, 90, 90, 90, + 90, 91, 90, 14, 114, 114, 90, 90, 90, 90, + 6, 135, 4, 145, 14, 6, 90, 149, 4, 4, + 4, 14, 110, 110, 3, 99, 99, 114, 99, 112, + 90, 90, 99, 6, 4, 90, 99, 99, 100, 36, + 37, 104, 104, 90, 107, 14, 99, 99, 107, 107, + 101, 99, 91, 99, 110, 107, 4, 114, 107, 115, + 90, 90, 99, 99, 104 }; typedef enum { @@ -904,23 +907,23 @@ static const toketypes yy_type_tab[] = toketype_ival, toketype_ival, toketype_ival, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_p_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, + toketype_opval, toketype_opval, toketype_p_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, - toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, + toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, + toketype_i_tkval, toketype_i_tkval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_i_tkval, toketype_ival, - toketype_ival, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_opval, - toketype_ival, 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_opval, - toketype_opval, toketype_p_tkval, 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_opval, toketype_opval, toketype_ival, - toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_i_tkval, toketype_ival, toketype_ival, toketype_opval, toketype_ival, toketype_ival, toketype_ival, + toketype_opval, toketype_ival, 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_opval, toketype_opval, toketype_p_tkval, 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_opval, toketype_opval, toketype_ival, 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_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_opval + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval }; @@ -73,6 +73,7 @@ %token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF %token <opval> FUNC0SUB UNIOPSUB LSTOPSUB +%token <opval> PLUGEXPR PLUGSTMT %token <p_tkval> LABEL %token <i_tkval> FORMAT SUB ANONSUB PACKAGE USE %token <i_tkval> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR @@ -157,7 +158,7 @@ remember: /* NULL */ /* start a full lexical scope */ ; mydefsv: /* NULL */ /* lexicalize $_ */ - { $$ = (I32) allocmy("$_"); } + { $$ = (I32) Perl_allocmy(aTHX_ STR_WITH_LEN("$_"), 0); } ; progstart: @@ -241,6 +242,8 @@ line : label cond } }) } + | label PLUGSTMT + { $$ = newSTATEOP(0, PVAL($1), $2); } ; /* An expression which may have a side-effect */ @@ -1244,6 +1247,7 @@ term : termbinop newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); TOKEN_GETMAD($1,$$,'X'); } + | PLUGEXPR ; /* "my" declarations, with optional attributes */ diff --git a/plan9/config.plan9 b/plan9/config.plan9 index 9164a41ff9..d19652d2e3 100644 --- a/plan9/config.plan9 +++ b/plan9/config.plan9 @@ -3364,8 +3364,8 @@ * 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.11.1" /**/ -#define PRIVLIB_EXP "/sys/lib/perl/5.11.1" /**/ +#define PRIVLIB "/sys/lib/perl/5.11.2" /**/ +#define PRIVLIB_EXP "/sys/lib/perl/5.11.2" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -3492,9 +3492,9 @@ * 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.11.1/site_perl" /**/ -#define SITELIB_EXP "/sys/lib/perl/5.11.1/site_perl" /**/ -#define SITELIB_STEM "/sys/lib/perl/5.11.1/site_perl" /**/ +#define SITELIB "/sys/lib/perl/5.11.2/site_perl" /**/ +#define SITELIB_EXP "/sys/lib/perl/5.11.2/site_perl" /**/ +#define SITELIB_STEM "/sys/lib/perl/5.11.2/site_perl" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. diff --git a/plan9/config_sh.sample b/plan9/config_sh.sample index c11635953a..340947bb08 100644 --- a/plan9/config_sh.sample +++ b/plan9/config_sh.sample @@ -36,8 +36,8 @@ api_subversion='0' api_version='11' api_versionstring='5.11.0' ar='ar' -archlib='/sys/lib/perl5/5.11.1/386' -archlibexp='/sys/lib/perl5/5.11.1/386' +archlib='/sys/lib/perl5/5.11.2/386' +archlibexp='/sys/lib/perl5/5.11.2/386' archname64='' archname='386' archobjs='' @@ -64,6 +64,7 @@ ccversion='' cf_by='9trouble' cf_email='9trouble@plan9.bell-labs.com' cf_time='Sun Nov 24 20:57:48 EST 2002' +charbits='8' chgrp='' chmod='chmod' chown='' @@ -712,17 +713,17 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='/sys/lib/perl/5.11.1/386' +installarchlib='/sys/lib/perl/5.11.2/386' installbin='/usr/bin' installman1dir='/sys/man/1pub' installman3dir='/sys/man/2pub' installprefix='/usr' installprefixexp='/usr' -installprivlib='/sys/lib/perl/5.11.1' +installprivlib='/sys/lib/perl/5.11.2' installscript='/usr/bin' -installsitearch='/sys/lib/perl/5.11.1/site_perl/386' +installsitearch='/sys/lib/perl/5.11.2/site_perl/386' installsitebin='/usr/bin' -installsitelib='/sys/lib/perl/5.11.1/site_perl' +installsitelib='/sys/lib/perl/5.11.2/site_perl' installstyle='lib/perl5' installusrbinperl='undef' installvendorarch='' @@ -733,7 +734,7 @@ issymlink='/bin/test -h' ivdformat='"ld"' ivsize='4' ivtype='long' -known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared' +known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared' ksh='' ld='ld' lddlflags='' @@ -841,8 +842,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/sys/lib/perl/5.11.1' -privlibexp='/sys/lib/perl/5.11.1' +privlib='/sys/lib/perl/5.11.2' +privlibexp='/sys/lib/perl/5.11.2' procselfexe='' prototype='define' ptrsize='4' @@ -907,13 +908,13 @@ sig_num='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 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.11.1/site_perl/386' +sitearch='/sys/lib/perl/5.11.2/site_perl/386' sitearchexp='/sys/lib/perl/site_perl/386' sitebin='/usr/bin' sitebinexp='/usr/bin' -sitelib='/sys/lib/perl/5.11.1/site_perl' -sitelib_stem='/sys/lib/perl/5.11.1/site_perl' -sitelibexp='/sys/lib/perl/5.11.1/site_perl' +sitelib='/sys/lib/perl/5.11.2/site_perl' +sitelib_stem='/sys/lib/perl/5.11.2/site_perl' +sitelibexp='/sys/lib/perl/5.11.2/site_perl' siteprefix='/usr' siteprefixexp='/usr' sizesize='4' @@ -944,7 +945,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/sys/include/ape/string.h' submit='' -subversion='1' +subversion='2' sysman='/sys/man/1pub' tail='' tar='' @@ -1021,8 +1022,8 @@ vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.11.1' -version_patchlevel_string='version 11 subversion 1' +version='5.11.2' +version_patchlevel_string='version 11 subversion 2' versiononly='undef' vi='' voidflags='15' @@ -1037,7 +1038,7 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=11 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=11 PERL_API_SUBVERSION=0 @@ -83,6 +83,7 @@ h Reference Manual perluniintro Perl Unicode introduction perlunicode Perl Unicode support perlunifaq Perl Unicode FAQ +g perluniprops Complete index of Unicode Version 5.1.0 properties perlunitut Perl Unicode tutorial perlebcdic Considerations for running Perl on EBCDIC platforms @@ -135,7 +136,8 @@ h Miscellaneous perlhist Perl history records d perldelta Perl changes since previous version -D perl5112delta Perl changes in version 5.11.2 +D perl5113delta Perl changes in version 5.11.3 + perl5112delta Perl changes in version 5.11.2 perl5111delta Perl changes in version 5.11.1 perl5110delta Perl changes in version 5.11.0 perl5101delta Perl changes in version 5.10.1 diff --git a/pod/.gitignore b/pod/.gitignore index 21c119d9e9..61b9c7bbac 100644 --- a/pod/.gitignore +++ b/pod/.gitignore @@ -35,6 +35,7 @@ /perltoc.pod /perltru64.pod /perltw.pod +/perluniprops.pod /perluts.pod /perlvmesa.pod /perlvms.pod diff --git a/pod/perl.pod b/pod/perl.pod index 81eba84c3a..06a7dc1030 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -97,6 +97,7 @@ For ease of access, the Perl manual has been split up into several sections. perluniintro Perl Unicode introduction perlunicode Perl Unicode support perlunifaq Perl Unicode FAQ + perluniprops Complete index of Unicode Version 5.1.0 properties perlunitut Perl Unicode tutorial perlebcdic Considerations for running Perl on EBCDIC platforms @@ -149,6 +150,7 @@ For ease of access, the Perl manual has been split up into several sections. perlhist Perl history records perldelta Perl changes since previous version + perl5112delta Perl changes in version 5.11.2 perl5111delta Perl changes in version 5.11.1 perl5110delta Perl changes in version 5.11.0 perl5101delta Perl changes in version 5.10.1 diff --git a/pod/perl5112delta.pod b/pod/perl5112delta.pod index b2a6522b02..c53a622c4c 100644 --- a/pod/perl5112delta.pod +++ b/pod/perl5112delta.pod @@ -1,54 +1,69 @@ =head1 NAME -[ Any text flagged as XXX needs to be processed before release. ] - -perldelta - what is new for perl v5.11.2 +perl5112delta - what is new for perl v5.11.2 =head1 DESCRIPTION -This document describes differences between the 5.11.1 release and -the 5.11.2 release. - -=head1 Notice - -XXX Unlikely to need this section. - -=head1 Incompatible Changes - -XXX For a release on a stable branch, this section aspires to be: - - There are no changes intentionally incompatible with 5.XXX.XXX. If any - exist, they are bugs and reports are welcome. - +This document describes differences between the 5.11.1 release and the +5.11.2 release. =head1 Core Enhancements -XXX New core language features go here. Summarise user-visible core language -enhancements. Particularly prominent performance optimisations could go -here, but most should go in the L</Performance Enhancements> section. - -=head1 New Platforms - -XXX List any platforms that this version of perl compiles on, that previous -versions did not. These will either be enabled by new files in the F<hints/> -directories, or new subdirectories and F<README> files at the top level of the -source tree. +=head2 qr overloading + +It is now possible to overload the C<qr//> operator, that is, +conversion to regexp, like it was already possible to overload +conversion to boolean, string or number of objects. It is invoked when +an object appears on the right hand side of the C<=~> operator, or when +it is interpolated into a regexp. See L<overload>. + +=head2 Pluggable keywords + +Extension modules can now cleanly hook into the Perl parser to define +new kinds of keyword-headed expression and compound statement. The +syntax following the keyword is defined entirely by the extension. This +allow a completely non-Perl sublanguage to be parsed inline, with the +right ops cleanly generated. This feature is currently considered +experimental. + +See L<perlapi/PL_keyword_plugin> for the mechanism. The Perl core +source distribution also includes a new module +L<XS::APItest::KeywordRPN>, which implements reverse Polish notation +arithmetic via pluggable keywords. This module is mainly used for test +purposes, and is not normally installed, but also serves as an example +of how to use the new mechanism. + +=head2 APIs for more internals + +The lowest layers of the lexer and parts of the pad system now have C +APIs available to XS extensions. These are necessary to support proper +use of pluggable keywords, but have other uses too. The new APIs are +experimental, and only cover a small proportion of what would be +necessary to take full advantage of the core's facilities in these +areas. It is intended that the Perl 5.13 development cycle will see the +addition of a full range of clean, supported interfaces. + +=head2 Overridable function lookup + +Where an extension module hooks the creation of rv2cv ops to modify the +subroutine lookup process, this now works correctly for bareword +subroutine calls. This means that prototypes on subroutines referenced +this way will be processed correctly. (Previously bareword subroutine +names were initially looked up, for parsing purposes, by an unhookable +mechanism, so extensions could only properly influence subroutine names +that appeared with an C<&> sigil.) =head1 Modules and Pragmata -XXX All changes to installed files in F<cpan/>, F<dist/>, F<ext/> and F<lib/> -go here, in a list ordered by distribution name. Minimally it should be the -module version, but it's more useful to the end user to give a paragraph's -summary of the module's changes. In an ideal world, dual-life modules would -have a F<Changes> file that could be cribbed. - =head2 New Modules and Pragmata =over 4 -=item C<XXX> +=item C<legacy> -XXX +Preserves legacy behaviors or enable new non-default behaviors. +Currently the only behaviour concerns semantics for the 128 characters +on ASCII systems that have the 8th bit set. =back @@ -56,9 +71,13 @@ XXX =over 4 -=item C<XXX> +=item C<diagnostics> + +Supports %.0f formatting internally. + +=item C<overload> -XXX +Allow overloading of 'qr'. =back @@ -66,102 +85,145 @@ XXX =over 4 -=item C<XXX> +=item C<B::Concise> -XXX +Optimize reversing an array in-place, avoid using defined %hash in core +code and tests. -=back +=item C<B::Deparse> -=head1 Utility Changes +Teach B::Deparse about in-place reverse. -XXX Changes to installed programs such as F<perlbug> and F<xsubpp> go -here. Most of these are built within the directories F<utils> and F<x2p>. +=item C<Carp> -=over 4 +Refine Carp caller() fix and add tests. -=item F<XXX> +=item C<Compress::Zlib> -XXX +Updated to 2.022. -=back +=item C<CPANPLUS> -=head1 New Documentation +Updated to 0.89_09. -XXX Changes which create B<new> files in F<pod/> go here. +=item C<Encode> -=over 4 +Updated to 2.38. -=item L<XXX> +=item C<ExtUtils::CBuilder> -XXX +Updated to 0.27. -=back +=item C<Env> -=head1 Changes to Existing Documentation +Add EXISTS and DELETE methods to Env.pm. -XXX Changes which significantly change existing files in F<pod/> go here. -Any changes to F<pod/perldiag.pod> should go in L</New or Changed Diagnostics>. +=item C<File::Fetch> +Updated to 0.22. -=head1 Performance Enhancements +=item C<I8N::Langinfo> -XXX Changes which enhance performance without changing behaviour go here. There -may well be none in a stable release. +Correctly document export of I18N::Langinfo. -=over 4 +=item C<I8N::LangTags> -=item * +In I18N::LangTags::Detect, avoid using defined @array and defined +%hash. -XXX +=item C<IO::Compress> -=back +Updated to 2.022. -=head1 Installation and Configuration Improvements +=item C<IPC::Cmd> -XXX Changes to F<Configure>, F<installperl>, F<installman>, and analogous tools -go here. +Updated to 0.54. -=head2 Configuration improvements +=item C<List::Util> -XXX +Updated to 1.22. -=head2 Compilation improvements +=item C<Locale::Maketext> -XXX +In Locale::Maketext, avoid using defined @array and defined %hash. +Convert the odd Locale::Maketext test out from Test to Test::More. -=head2 Platform Specific Changes +=item C<Module::Build> -=over 4 +Updated to 0.35_08. -=item XXX-some-platform +=item C<Module::CoreList> -XXX +Implemented is_deprecated(). + +=item C<Pod::Simple> + +Updated to 3.10. + +=item C<Scalar::Util> + +Updated to 1.22. + +=item C<Switch> + +Updated to 2.16. =back -=head1 Selected Bug Fixes +=head1 Utility Changes -XXX Important bug fixes in the core language are summarised here. -Bug fixes in files in F<ext/> and F<lib/> are best summarised in -L</Modules and Pragmata>. +=over 4 + +=item F<a2p> + +Fixed bugs with the match() operator in list context, remove mention of +$[. + +=back + +=head1 Performance Enhancements =over 4 =item * -XXX +Reversing an array to itself (as in C<@a = reverse @a>) in void context +now happens in-place and is several orders of magnitude faster than it +used to be. It will also preserve non-existent elements whenever +possible, i.e. for non magical arrays or tied arrays with C<EXISTS> and +C<DELETE> methods. =back =head1 New or Changed Diagnostics -XXX New or changed warnings emitted by the core's C<C> code go here. +Several new diagnostics, see L<perldiag> for details. =over 4 -=item C<XXX> +=item C<Bad plugin affecting keyword '%s'> + +=item C<gmtime(%.0f) too large> -XXX +=item C<Lexing code attempted to stuff non-Latin-1 character into Latin-1 input> + +=item C<Lexing code internal error (%s)> + +=item C<localtime(%.0f) too large> + +=item C<Overloaded dereference did not return a reference> + +=item C<Overloaded qr did not return a REGEXP> + +=item C<Perl_pmflag() is deprecated, and will be removed from the XS API> + +=back + +One diagnostic has been removed: + +=over 4 + +=item C<Runaway format> =back @@ -171,102 +233,111 @@ XXX =item * -C<Perl_pmflag> has been removed from the public API. Calling it now generates -a deprecation warning, and it will be removed in a future release. Although -listed as part of the API, it was never documented, and only ever used in -F<toke.c>, and prior to 5.10, F<regcomp.c>. In core, it has been replaced by a -static function. +C<Perl_pmflag> has been removed from the public API. Calling it now +generates a deprecation warning, and it will be removed in a future +release. Although listed as part of the API, it was never documented, +and only ever used in F<toke.c>, and prior to 5.10, F<regcomp.c>. In +core, it has been replaced by a static function. =back =head1 New Tests -XXX Changes which create B<new> files in F<t/> go here. Changes to -existing files in F<t/> aren't worth summarising, although the bugs that -they represent may be. - =over 4 -=item F<XXX> +=item F<t/op/while_readdir.t> -XXX +Test that a bare readdir in while loop sets $_. =back =head1 Known Problems -XXX Descriptions of platform agnostic bugs we know we can't fix go here. Any -tests that had to be C<TODO>ed for the release would be noted here, unless -they were specific to a particular platform (see below). - -This is a list of some significant unfixed bugs, which are regressions -from either 5.10.1 or 5.11.1. - =over 4 -=item * +=item Known test failures on VMS -XXX +Perl 5.11.2 fails a small set of core and CPAN tests as of this +release. With luck, that'll be sorted out for 5.11.3. =back =head1 Deprecations -XXX Add any new known deprecations here. - The following items are now deprecated. -=over 4 +=head2 Use of C<:=> to mean an empty attribute list is now deprecated. -=item * +An accident of Perl's parser meant that these constructions were all +equivalent: -XXX + my $pi := 4; + my $pi : = 4; + my $pi : = 4; -=back - -=head1 Platform Specific Notes +with the C<:> being treated as the start of an attribute list, which +ends before the C<=>. As whitespace is not significant here, all are +parsed as an empty attribute list, hence all the above are equivalent +to, and better written as -XXX Any changes specific to a particular platform. VMS and Win32 are the usual -stars here. It's probably best to group changes under the same section layout -as the main perldelta + my $pi = 4; -=head1 Obituary +because no attribute processing is done for an empty list. -XXX If any significant core contributor has died, we've added a short obituary -here. +As is, this meant that C<:=> cannot be used as a new token, without +silently changing the meaning of existing code. Hence that particular +form is now deprecated, and will become a syntax error. If it is +absolutely necessary to have empty attribute lists (for example, +because of a code generator) then avoid the warning by adding a space +before the C<=>. =head1 Acknowledgements -XXX The list of people to thank goes here. +Perl 5.11.2 represents approximately 3 weeks development since Perl +5.11.1 and contains 29,992 lines of changes across 458 files from 38 +authors and committers: + +Abhijit Menon-Sen, Abigail, Ben Morrow, Bo Borgerson, Brad Gilbert, +Bram, Chris Williams, Craig A. Berry, Daniel Frederick Crisman, Dave +Rolsky, David E. Wheeler, David Golden, Eric Brine, Father +Chrysostomos, Frank Wiegand, Gerard Goossen, Gisle Aas, Graham Barr, +Harmen, H.Merijn Brand, Jan Dubois, Jerry D. Hedden, Jesse Vincent, +Karl Williamson, Kevin Ryde, Leon Brocard, Nicholas Clark, Paul +Marquess, Philippe Bruhat, Rafael Garcia-Suarez, Sisyphus, Steffen +Mueller, Steve Hay, Steve Peters, Vincent Pit, Yuval Kogman, Yves +Orton, and Zefram. +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. =head1 Reporting Bugs If you find what you think is a bug, you might check the articles -recently posted to the comp.lang.perl.misc newsgroup and the perl -bug database at http://rt.perl.org/perlbug/ . There may also be -information at http://www.perl.org/ , the Perl Home Page. +recently posted to the comp.lang.perl.misc newsgroup and the perl bug +database at http://rt.perl.org/perlbug/ . There may also be information +at http://www.perl.org/ , the Perl Home Page. If you believe you have an unreported bug, please run the B<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. +program included with your release. Be sure to trim your bug down to a +tiny but sufficient test case. Your bug report, along with the output +of C<perl -V>, will be sent off to perlbug@perl.org to be analysed by +the Perl porting team. If the bug you are reporting has security implications, which make it -inappropriate to send to a publicly archived mailing list, then please send -it to perl5-security-report@perl.org. This points to a closed subscription -unarchived mailing list, which includes all the core committers, who be able -to help assess the impact of issues, figure out a resolution, and help -co-ordinate the release of patches to mitigate or fix the problem across all -platforms on which Perl is supported. Please only use this address for -security issues in the Perl core, not for modules independently -distributed on CPAN. +inappropriate to send to a publicly archived mailing list, then please +send it to perl5-security-report@perl.org. This points to a closed +subscription unarchived mailing list, which includes all the core +committers, who be able to help assess the impact of issues, figure out +a resolution, and help co-ordinate the release of patches to mitigate +or fix the problem across all platforms on which Perl is supported. +Please only use this address for security issues in the Perl core, not +for modules independently distributed on CPAN. =head1 SEE ALSO -The F<Changes> file for an explanation of how to view exhaustive details -on what changed. +The F<Changes> file for an explanation of how to view exhaustive +details on what changed. The F<INSTALL> file for how to build Perl. diff --git a/pod/perl5113delta.pod b/pod/perl5113delta.pod new file mode 100644 index 0000000000..ea2c0fb675 --- /dev/null +++ b/pod/perl5113delta.pod @@ -0,0 +1,382 @@ +=head1 NAME + +[ this is a template for a new perldelta file. Any text flagged as +XXX needs to be processed before release. ] + +perldelta - what is new for perl v5.11.3 + +=head1 DESCRIPTION + +This document describes differences between the 5.11.3 release and +the 5.11.3 release. + +If you are upgrading from an earlier release such as 5.11.3, first read +the L<perl5XXXdelta>, which describes differences between 5.11.3 and +5.10.0 + +=head1 Notice + +XXX Any important notices here + +=head1 Incompatible Changes + +XXX For a release on a stable branch, this section aspires to be: + + There are no changes intentionally incompatible with 5.11.3. If any + exist, they are bugs and reports are welcome. + + +=head1 Core Enhancements + +XXX New core language features go here. Summarise user-visible core language +enhancements. Particularly prominent performance optimisations could go +here, but most should go in the L</Performance Enhancements> section. + +=head2 Unicode properties + +Perl can now handle every Unicode character property. A new pod, +L<perluniprops>, lists all available non-Unihan character properties. By +default the Unihan properties and certain others (deprecated and Unicode +internal-only ones) are not exposed. See below for more details on +these; there is also a section in the pod listing them, and why they are +not exposed. + +Perl now fully supports the Unicode compound-style of using C<=> and C<:> +in writing regular expressions: C<\p{property=value}> and +C<\p{property:value}> (both of which mean the same thing). + +Perl now supports fully the Unicode loose matching rules for text +between the braces in C<\p{...}> constructs. In addition, Perl also allows +underscores between digits of numbers. + +All the Unicode-defined synonyms for properties and property values are +now accepted. + +C<\p{...}> matches using the Canonical_Combining_Class property were +completely broken in previous Perls. This is now fixed. + +In previous Perls, the Unicode Decomposition_Type=Compat property and a +Perl extension had the same name, which led to neither matching all the +correct values (with more than 100 mistakes in one, and several thousand +in the other). The Perl extension has now been renamed to be +Decomposition_Type=Noncanonical (short: dt=noncanon). It has the same +meaning as was previously intended, namely the union of all the +non-canonical Decomposition types, with Unicode Compat being just one of +those. + +C<\p{Uppercase}> and C<\p{Lowercase}> have been brought into line with the +Unicode definitions. This means they each match a few more characters +than previously. + +C<\p{Cntrl}> now matches the same characters as C<\p{Control}>. This means it +no longer will match Private Use (gc=co), Surrogates (gc=cs), nor Format +(gc=cf) code points. The Format code points represent the biggest +possible problem. All but 36 of them are either officially deprecated +or strongly discouraged from being used. Of those 36, likely the most +widely used are the soft hyphen (U+00AD), and BOM, ZWSP, ZWNJ, WJ, and +similar, plus Bi-directional controls. + +C<\p{Alpha}> now matches the same characters as C<\p{Alphabetic}>. The Perl +definition included a number of things that aren't really alpha (all +marks), while omitting many that were. The Unicode definition is +clearly better, so we are switching to it. As a direct consequence, the +definitions of C<\p{Alnum}> and C<\p{Word}> which depend on Alpha also change. + +C<\p{Word}> also now doesn't match certain characters it wasn't supposed +to, such as fractions. + +C<\p{Print}> no longer matches the line control characters: tab, lf, cr, +ff, vt, and nel. This brings it in line with the documentation. + +\p{Decomposition_Type=Canonical} now includes the Hangul syllables + +The Numeric type property has been extended to include the Unihan +characters. + +There is a new Perl extension, the 'Present_In', or simply 'In' +property. This is an extension of the Unicode Age property, but +C<\p{In=5.0}> matches any code point whose usage has been determined as of +Unicode version 5.0. The C<\p{Age=5.0}> only matches code points added in 5.0. + +A number of properties did not have the correct values for unassigned +code points. This is now fixed. The affected properties are +Bidi_Class, East_Asian_Width, Joining_Type, Decomposition_Type, +Hangul_Syllable_Type, Numeric_Type, and Line_Break. + +The Default_Ignorable_Code_Point, ID_Continue, and ID_Start properties +have been updated to their current definitions. + +Certain properties that are supposed to be Unicode internal-only were +erroneously exposed by previous Perls. Use of these in regular +expressions will now generate a deprecated warning message, if those +warnings are enabled. The properties are: Other_Alphabetic, +Other_Default_Ignorable_Code_Point, Other_Grapheme_Extend, +Other_ID_Continue, Other_ID_Start, Other_Lowercase, Other_Math, and +Other_Uppercase. + +An installation can now fairly easily change Perl to operate on any +Unicode release. Perl is shipped with the latest official release, but +an installation can now download any prior release, and Perl will work +with that. Instructions are in L<perlunicode>. + +An installation can now fairly easily change which Unicode properties +Perl understands. As mentioned above, certain properties are by default +turned off. These include all the Unihan properties (which should be +accessible via the CPAN module Unicode::Unihan) and any deprecated or +Unicode internal-only property that Perl has never exposed. + +The files in the To directory are now more clearly marked as being +stable, directly usable by applications. New hash entries in them give +the format of the normal entries which allows for easier machine +parsing. Perl can generate files in this directory for any property, +though most are suppressed. An installation can choose to change which +get written. Instructions are in L<perluniprops>. + +=head1 New Platforms + +XXX List any platforms that this version of perl compiles on, that previous +versions did not. These will either be enabled by new files in the F<hints/> +directories, or new subdirectories and F<README> files at the top level of the +source tree. + +=head1 Modules and Pragmata + +XXX All changes to installed files in F<cpan/>, F<dist/>, F<ext/> and F<lib/> +go here, in a list ordered by distribution name. Minimally it should be the +module version, but it's more useful to the end user to give a paragraph's +summary of the module's changes. In an ideal world, dual-life modules would +have a F<Changes> file that could be cribbed. + +=head2 New Modules and Pragmata + +=over 4 + +=item C<XXX> + +XXX + +=back + +=head2 Pragmata Changes + +=over 4 + +=item C<XXX> + +XXX + +=back + +=head2 Updated Modules + +=over 4 + +=item C<XXX> + +XXX + +=back + +=head1 Utility Changes + +XXX Changes to installed programs such as F<perlbug> and F<xsubpp> go +here. Most of these are built within the directories F<utils> and F<x2p>. + +=over 4 + +=item F<XXX> + +XXX + +=back + +=head1 New Documentation + +XXX Changes which create B<new> files in F<pod/> go here. + +=over 4 + +=item L<XXX> + +XXX + +=back + +=head1 Changes to Existing Documentation + +XXX Changes which significantly change existing files in F<pod/> go here. +Any changes to F<pod/perldiag.pod> should go in L</New or Changed Diagnostics>. + + +=head1 Performance Enhancements + +XXX Changes which enhance performance without changing behaviour go here. There +may well be none in a stable release. + +=over 4 + +=item * + +XXX + +=back + +=head1 Installation and Configuration Improvements + +XXX Changes to F<Configure>, F<installperl>, F<installman>, and analogous tools +go here. + +=head2 Configuration improvements + +XXX + +=head2 Compilation improvements + +XXX + +=head2 Platform Specific Changes + +=over 4 + +=item XXX-some-platform + +XXX + +=back + +=head1 Selected Bug Fixes + +XXX Important bug fixes in the core language are summarised here. +Bug fixes in files in F<ext/> and F<lib/> are best summarised in +L</Modules and Pragmata>. + +=over 4 + +=item * + +XXX + +=back + +=head1 New or Changed Diagnostics + +XXX New or changed warnings emitted by the core's C<C> code go here. + +=over 4 + +=item C<XXX> + +XXX + +=back + +=head1 Changed Internals + +XXX Changes which affect the interface available to C<XS> code go here. + +=over 4 + +=item * + +XXX + +=back + +=head1 New Tests + +XXX Changes which create B<new> files in F<t/> go here. Changes to +existing files in F<t/> aren't worth summarising, although the bugs that +they represent may be. + +=over 4 + +=item F<XXX> + +XXX + +=back + +=head1 Known Problems + +XXX Descriptions of platform agnostic bugs we know we can't fix go here. Any +tests that had to be C<TODO>ed for the release would be noted here, unless +they were specific to a particular platform (see below). + +This is a list of some significant unfixed bugs, which are regressions +from either 5.11.3 or 5.11.3. + +=over 4 + +=item * + +XXX + +=back + +=head1 Deprecations + +XXX Add any new known deprecations here. + +The following items are now deprecated. + +=over 4 + +=item Use of "goto" to jump into a construct is deprecated + +Using C<goto> to jump from an outer scope into an inner +scope is now deprecated. This rare use case was causing +problems in the implementation of scopes. + +=back + +=head1 Platform Specific Notes + +XXX Any changes specific to a particular platform. VMS and Win32 are the usual +stars here. It's probably best to group changes under the same section layout +as the main perldelta + +=head1 Obituary + +XXX If any significant core contributor has died, we've added a short obituary +here. + +=head1 Acknowledgements + +XXX The list of people to thank goes here. + + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the articles +recently posted to the comp.lang.perl.misc newsgroup and the perl +bug database at http://rt.perl.org/perlbug/ . There may also be +information at http://www.perl.org/ , the Perl Home Page. + +If you believe you have an unreported bug, please run the B<perlbug> +program included with your release. Be sure to trim your bug down +to a tiny but sufficient test case. Your bug report, along with the +output of C<perl -V>, will be sent off to perlbug@perl.org to be +analysed by the Perl porting team. + +If the bug you are reporting has security implications, which make it +inappropriate to send to a publicly archived mailing list, then please send +it to perl5-security-report@perl.org. This points to a closed subscription +unarchived mailing list, which includes all the core committers, who be able +to help assess the impact of issues, figure out a resolution, and help +co-ordinate the release of patches to mitigate or fix the problem across all +platforms on which Perl is supported. Please only use this address for +security issues in the Perl core, not for modules independently +distributed on CPAN. + +=head1 SEE ALSO + +The F<Changes> file for an explanation of how to view exhaustive details +on what changed. + +The F<INSTALL> file for how to build Perl. + +The F<README> file for general stuff. + +The F<Artistic> and F<Copying> files for copyright information. + +=cut diff --git a/pod/perl588delta.pod b/pod/perl588delta.pod index e0ed647d56..16082b5ed9 100644 --- a/pod/perl588delta.pod +++ b/pod/perl588delta.pod @@ -1383,7 +1383,7 @@ happens at program exit, it may be skipped completely. =item * -Salvador Fandiño provided improvements to reduce the memory usage of C<sort> +Salvador Fandiño provided improvements to reduce the memory usage of C<sort> and to speed up some cases. =item * diff --git a/pod/perl593delta.pod b/pod/perl593delta.pod index 80f8cb925f..d67a5a56f7 100644 --- a/pod/perl593delta.pod +++ b/pod/perl593delta.pod @@ -107,7 +107,7 @@ details. (Contributed by Gisle Aas.) The support for assertions, introduced in perl 5.9.0, has been improved. The syntax for the C<-A> command-line switch has changed; it now accepts an optional module name, defaulting to C<assertions::activate>. See -L<assertions> and L<perlrun>. (Contributed by Salvador Fandiño García.) +L<assertions> and L<perlrun>. (Contributed by Salvador Fandiño GarcÃa.) =head2 Unicode Character Database 4.1.0 @@ -274,7 +274,7 @@ happens at program exit, it may be skipped completely. =head2 sort() enhancements -Salvador Fandiño provided improvements to reduce the memory usage of C<sort> +Salvador Fandiño provided improvements to reduce the memory usage of C<sort> and to speed up some cases. =head1 Installation and Configuration Improvements diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 3f0a78a3fe..42fe77ecee 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -373,6 +373,11 @@ is not the same as $var = 'myvar'; $sym = "mypack::$var"; +=item Bad plugin affecting keyword '%s' + +(F) An extension using the keyword plugin mechanism violated the +plugin API. + =item Bad realloc() ignored (S malloc) An internal routine called realloc() on something that had @@ -1837,6 +1842,12 @@ a term, so it's looking for the corresponding right angle bracket, and not finding it. Chances are you left some needed parentheses out earlier in the line, and you really meant a "less than". +=item gmtime(%.0f) too large + +(W overflow) You called C<gmtime> with an number that was beyond the 64-bit +range that it accepts, and some rounding resulted. This warning is also +triggered with nan (the special not-a-number value). + =item Got an error from DosAllocMem (P) An error peculiar to OS/2. Most probably you're using an obsolete @@ -2249,12 +2260,31 @@ effective uids or gids failed. length/code combination tried to obtain more data. This results in an undefined value for the length. See L<perlfunc/pack>. +=item Lexing code attempted to stuff non-Latin-1 character into Latin-1 input + +(F) An extension is attempting to insert text into the current parse +(using L<lex_stuff_pvn_flags|perlapi/lex_stuff_pvn_flags> or similar), but +tried to insert a character that couldn't be part of the current input. +This is an inherent pitfall of the stuffing mechanism, and one of the +reasons to avoid it. Where it is necessary to stuff, stuffing only +plain ASCII is recommended. + +=item Lexing code internal error (%s) + +(F) Lexing code supplied by an extension violated the lexer's API in a +detectable way. + =item listen() on closed socket %s (W closed) You tried to do a listen on a closed socket. Did you forget to check the return value of your socket() call? See L<perlfunc/listen>. +=item localtime(%.0f) too large + +(W overflow) You called C<localtime> with an number that was beyond the +64-bit range that it accepts, and some rounding resulted. This warning is also triggered with nan (the special not-a-number value). + =item Lookbehind longer than %d not implemented in regex m/%s/ (F) There is currently a limit on the length of string which lookbehind can @@ -4753,6 +4783,11 @@ to access the filehandle slot within a typeglob. operator. Since C<split> always tries to match the pattern repeatedly, the C</g> has no effect. +=item Use of "goto" to jump into a construct is deprecated + +(D deprecated) Using C<goto> to jump from an outer scope into an inner +scope is deprecated and should be avoided. + =item Use of inherited AUTOLOAD for non-method %s() is deprecated (D deprecated) As an (ahem) accidental feature, C<AUTOLOAD> subroutines diff --git a/pod/perlebcdic.pod b/pod/perlebcdic.pod index 1a83e01f84..962244ae2c 100644 --- a/pod/perlebcdic.pod +++ b/pod/perlebcdic.pod @@ -699,7 +699,7 @@ it in tr/// like so: my $ebcdic_string = $ascii_string; eval '$ebcdic_string =~ tr/' . $cp_037 . '/\000-\377/'; -To convert from EBCDIC 037 to ASCII just reverse the order of the tr/// +To convert from EBCDIC 037 to ASCII just reverse the order of the tr/// arguments like so: my $ascii_string = $ebcdic_string; @@ -1009,7 +1009,7 @@ to use the characters in the range explicitly: sub Is_latin_1 { my $char = substr(shift,0,1); - $char =~ /[ ¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ]/; + $char =~ /[ ¡¢£¤¥¦§¨©ª«¬Â®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÃÂÃÄÅÆÇÈÉÊËÌÃÃŽÃÃÑÒÓÔÕÖ×ØÙÚÛÜÃÞßà áâãäåæçèéêëìÃîïðñòóôõö÷øùúûüýþÿ]/; } Although that form may run into trouble in network transit (due to the @@ -1062,9 +1062,9 @@ then sort(). If the data are primarily lowercase non Latin 1 then apply tr/[A-Z]/[a-z]/ before sorting. If the data are primarily UPPERCASE and include Latin-1 characters then apply: - tr/[a-z]/[A-Z]/; - tr/[àáâãäåæçèéêëìíîïðñòóôõöøùúûüýþ]/[ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ]/; - s/ß/SS/g; + tr/[a-z]/[A-Z]/; + tr/[à áâãäåæçèéêëìÃîïðñòóôõöøùúûüýþ]/[ÀÃÂÃÄÅÆÇÈÉÊËÌÃÃŽÃÃÑÒÓÔÕÖØÙÚÛÜÃÞ/; + s/ß/SS/g; then sort(). Do note however that such Latin-1 manipulation does not address the E<yuml> C<y WITH DIAERESIS> character that will remain at diff --git a/pod/perlfaq.pod b/pod/perlfaq.pod index 16124962a2..96623ad4a7 100644 --- a/pod/perlfaq.pod +++ b/pod/perlfaq.pod @@ -28,7 +28,7 @@ https://github.com/briandfoy/perlfaq (which is outside of the main Perl source tree). The git repository notes all changes to the FAQ and holds the latest version of the working documents and may vary significantly from the version distributed with the latest version of -Perl. Check the repository before sending your corrections. +Perl. Check the repository before sending your corrections. =head2 How to contribute to the perlfaq diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index 8ddcabb370..c1ba5bb1b0 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -67,14 +67,14 @@ From the command line, you can use the C<cpan> command's C<-l> switch: $ cpan -l You can also use C<cpan>'s C<-a> switch to create an autobundle file -that C<CPAN.pm> understands and cna use to re-install every module: +that C<CPAN.pm> understands and can use to re-install every module: $ cpan -a Inside a Perl program, you can use the ExtUtils::Installed module to show all installed distributions, although it can take awhile to do its magic. The standard library which comes with Perl just shows up -as "Perl" (although you can get those with Module::CoreList). +as "Perl" (although you can get those with C<Module::CoreList>). use ExtUtils::Installed; @@ -82,7 +82,7 @@ as "Perl" (although you can get those with Module::CoreList). my @modules = $inst->modules(); If you want a list of all of the Perl module filenames, you -can use File::Find::Rule. +can use C<File::Find::Rule>: use File::Find::Rule; @@ -94,7 +94,7 @@ can use File::Find::Rule. ; If you do not have that module, you can do the same thing -with File::Find which is part of the standard library. +with File::Find which is part of the standard library: use File::Find; my @files; @@ -117,12 +117,12 @@ If you simply need to quickly check to see if a module is available, you can check for its documentation. If you can read the documentation the module is most likely installed. If you cannot read the documentation, the module might not -have any (in rare cases). +have any (in rare cases): $ perldoc Module::Name You can also try to include the module in a one-liner to see if -perl finds it. +perl finds it: $ perl -MModule::Name -e1 @@ -307,6 +307,10 @@ ActiveState's cross-platform (as of October 2004, that's Windows, Linux, and Solaris), multi-language IDE has Perl support, including a regular expression debugger and remote debugging. +=item Notepad++ + +http://notepad-plus.sourceforge.net/ + =item Open Perl IDE http://open-perl-ide.sourceforge.net/ @@ -326,9 +330,8 @@ debugger and syntax highlighting editor. http://padre.perlide.org/ -Padre is cross-platform IDE for Perl written in Perl using the the wxWidgets -to provide a native look and feel. It's open source under the Artistic -License. +Padre is cross-platform IDE for Perl written in Perl using wxWidgets to provide +a native look and feel. It's open source under the Artistic License. =item PerlBuilder @@ -364,7 +367,740 @@ anything. In any emacs the cperl-mode (M-x cperl-mode) gives you perhaps the best available Perl editing mode in any editor. If you are using Windows, you can use any editor that lets you work -with plain text, such as NotePad or WordPad. Word processors, such as +with plain text, such as NotePad or WordPad. Word processors, such as Microsoft Word or WordPerfect, typically do not work since they insert all sorts of behind-the-scenes information, although some allow you to -save files as "Text Only". You can also download te
\ No newline at end of file +save files as "Text Only". You can also download text editors designed +specifically for programming, such as Textpad ( +http://www.textpad.com/ ) and UltraEdit ( http://www.ultraedit.com/ ), +among others. + +If you are using MacOS, the same concerns apply. MacPerl (for Classic +environments) comes with a simple editor. Popular external editors are +BBEdit ( http://www.bbedit.com/ ) or Alpha ( +http://www.his.com/~jguyer/Alpha/Alpha8.html ). MacOS X users can use +Unix editors as well. + +=over 4 + +=item GNU Emacs + +http://www.gnu.org/software/emacs/windows/ntemacs.html + +=item MicroEMACS + +http://www.microemacs.de/ + +=item XEmacs + +http://www.xemacs.org/Download/index.html + +=item Jed + +http://space.mit.edu/~davis/jed/ + +=back + +or a vi clone such as + +=over 4 + +=item Elvis + +ftp://ftp.cs.pdx.edu/pub/elvis/ http://www.fh-wedel.de/elvis/ + +=item Vile + +http://dickey.his.com/vile/vile.html + +=item Vim + +http://www.vim.org/ + +=back + +For vi lovers in general, Windows or elsewhere: + + http://www.thomer.com/thomer/vi/vi.html + +nvi ( http://www.bostic.com/vi/ , available from CPAN in src/misc/) is +yet another vi clone, unfortunately not available for Windows, but in +UNIX platforms you might be interested in trying it out, firstly because +strictly speaking it is not a vi clone, it is the real vi, or the new +incarnation of it, and secondly because you can embed Perl inside it +to use Perl as the scripting language. nvi is not alone in this, +though: at least also vim and vile offer an embedded Perl. + +The following are Win32 multilanguage editor/IDEs that support Perl: + +=over 4 + +=item Codewright + +http://www.borland.com/codewright/ + +=item MultiEdit + +http://www.MultiEdit.com/ + +=item SlickEdit + +http://www.slickedit.com/ + +=item ConTEXT + +http://www.contexteditor.org/ + +=back + +There is also a toyedit Text widget based editor written in Perl +that is distributed with the Tk module on CPAN. The ptkdb +( http://ptkdb.sourceforge.net/ ) is a Perl/tk based debugger that +acts as a development environment of sorts. Perl Composer +( http://perlcomposer.sourceforge.net/ ) is an IDE for Perl/Tk +GUI creation. + +In addition to an editor/IDE you might be interested in a more +powerful shell environment for Win32. Your options include + +=over 4 + +=item Bash + +from the Cygwin package ( http://sources.redhat.com/cygwin/ ) + +=item Ksh + +from the MKS Toolkit ( http://www.mkssoftware.com/ ), or the Bourne shell of +the U/WIN environment ( http://www.research.att.com/sw/tools/uwin/ ) + +=item Tcsh + +ftp://ftp.astron.com/pub/tcsh/ , see also +http://www.primate.wisc.edu/software/csh-tcsh-book/ + +=item Zsh + +http://www.zsh.org/ + +=back + +MKS and U/WIN are commercial (U/WIN is free for educational and +research purposes), Cygwin is covered by the GNU General Public +License (but that shouldn't matter for Perl use). The Cygwin, MKS, +and U/WIN all contain (in addition to the shells) a comprehensive set +of standard UNIX toolkit utilities. + +If you're transferring text files between Unix and Windows using FTP +be sure to transfer them in ASCII mode so the ends of lines are +appropriately converted. + +On Mac OS the MacPerl Application comes with a simple 32k text editor +that behaves like a rudimentary IDE. In contrast to the MacPerl Application +the MPW Perl tool can make use of the MPW Shell itself as an editor (with +no 32k limit). + +=over 4 + +=item Affrus + +is a full Perl development environment with full debugger support +( http://www.latenightsw.com ). + +=item Alpha + +is an editor, written and extensible in Tcl, that nonetheless has +built in support for several popular markup and programming languages +including Perl and HTML ( http://www.his.com/~jguyer/Alpha/Alpha8.html ). + +=item BBEdit and BBEdit Lite + +are text editors for Mac OS that have a Perl sensitivity mode +( http://web.barebones.com/ ). + +=back + +=head2 Where can I get Perl macros for vi? + +For a complete version of Tom Christiansen's vi configuration file, +see http://www.cpan.org/authors/Tom_Christiansen/scripts/toms.exrc.gz , +the standard benchmark file for vi emulators. The file runs best with nvi, +the current version of vi out of Berkeley, which incidentally can be built +with an embedded Perl interpreter--see http://www.cpan.org/src/misc/ . + +=head2 Where can I get perl-mode for emacs? + +Since Emacs version 19 patchlevel 22 or so, there have been both a +perl-mode.el and support for the Perl debugger built in. These should +come with the standard Emacs 19 distribution. + +In the Perl source directory, you'll find a directory called "emacs", +which contains a cperl-mode that color-codes keywords, provides +context-sensitive help, and other nifty things. + +Note that the perl-mode of emacs will have fits with C<"main'foo"> +(single quote), and mess up the indentation and highlighting. You +are probably using C<"main::foo"> in new Perl code anyway, so this +shouldn't be an issue. + +=head2 How can I use curses with Perl? + +The Curses module from CPAN provides a dynamically loadable object +module interface to a curses library. A small demo can be found at the +directory http://www.cpan.org/authors/Tom_Christiansen/scripts/rep.gz ; +this program repeats a command and updates the screen as needed, rendering +B<rep ps axu> similar to B<top>. + +=head2 How can I write a GUI (X, Tk, Gtk, etc.) in Perl? +X<GUI> X<Tk> X<Wx> X<WxWidgets> X<Gtk> X<Gtk2> X<CamelBones> X<Qt> + +(contributed by Ben Morrow) + +There are a number of modules which let you write GUIs in Perl. Most +GUI toolkits have a perl interface: an incomplete list follows. + +=over 4 + +=item Tk + +This works under Unix and Windows, and the current version doesn't +look half as bad under Windows as it used to. Some of the gui elements +still don't 'feel' quite right, though. The interface is very natural +and 'perlish', making it easy to use in small scripts that just need a +simple gui. It hasn't been updated in a while. + +=item Wx + +This is a Perl binding for the cross-platform wxWidgets toolkit +( http://www.wxwidgets.org ). It works under Unix, Win32 and Mac OS X, +using native widgets (Gtk under Unix). The interface follows the C++ +interface closely, but the documentation is a little sparse for someone +who doesn't know the library, mostly just referring you to the C++ +documentation. + +=item Gtk and Gtk2 + +These are Perl bindings for the Gtk toolkit ( http://www.gtk.org ). The +interface changed significantly between versions 1 and 2 so they have +separate Perl modules. It runs under Unix, Win32 and Mac OS X (currently +it requires an X server on Mac OS, but a 'native' port is underway), and +the widgets look the same on every plaform: i.e., they don't match the +native widgets. As with Wx, the Perl bindings follow the C API closely, +and the documentation requires you to read the C documentation to +understand it. + +=item Win32::GUI + +This provides access to most of the Win32 GUI widgets from Perl. +Obviously, it only runs under Win32, and uses native widgets. The Perl +interface doesn't really follow the C interface: it's been made more +Perlish, and the documentation is pretty good. More advanced stuff may +require familiarity with the C Win32 APIs, or reference to MSDN. + +=item CamelBones + +CamelBones ( http://camelbones.sourceforge.net ) is a Perl interface to +Mac OS X's Cocoa GUI toolkit, and as such can be used to produce native +GUIs on Mac OS X. It's not on CPAN, as it requires frameworks that +CPAN.pm doesn't know how to install, but installation is via the +standard OSX package installer. The Perl API is, again, very close to +the ObjC API it's wrapping, and the documentation just tells you how to +translate from one to the other. + +=item Qt + +There is a Perl interface to TrollTech's Qt toolkit, but it does not +appear to be maintained. + +=item Athena + +Sx is an interface to the Athena widget set which comes with X, but +again it appears not to be much used nowadays. + +=back + +=head2 How can I make my Perl program run faster? + +The best way to do this is to come up with a better algorithm. This +can often make a dramatic difference. Jon Bentley's book +I<Programming Pearls> (that's not a misspelling!) has some good tips +on optimization, too. Advice on benchmarking boils down to: benchmark +and profile to make sure you're optimizing the right part, look for +better algorithms instead of microtuning your code, and when all else +fails consider just buying faster hardware. You will probably want to +read the answer to the earlier question "How do I profile my Perl +programs?" if you haven't done so already. + +A different approach is to autoload seldom-used Perl code. See the +AutoSplit and AutoLoader modules in the standard distribution for +that. Or you could locate the bottleneck and think about writing just +that part in C, the way we used to take bottlenecks in C code and +write them in assembler. Similar to rewriting in C, modules that have +critical sections can be written in C (for instance, the PDL module +from CPAN). + +If you're currently linking your perl executable to a shared +I<libc.so>, you can often gain a 10-25% performance benefit by +rebuilding it to link with a static libc.a instead. This will make a +bigger perl executable, but your Perl programs (and programmers) may +thank you for it. See the F<INSTALL> file in the source distribution +for more information. + +The undump program was an ancient attempt to speed up Perl program by +storing the already-compiled form to disk. This is no longer a viable +option, as it only worked on a few architectures, and wasn't a good +solution anyway. + +=head2 How can I make my Perl program take less memory? + +When it comes to time-space tradeoffs, Perl nearly always prefers to +throw memory at a problem. Scalars in Perl use more memory than +strings in C, arrays take more than that, and hashes use even more. While +there's still a lot to be done, recent releases have been addressing +these issues. For example, as of 5.004, duplicate hash keys are +shared amongst all hashes using them, so require no reallocation. + +In some cases, using substr() or vec() to simulate arrays can be +highly beneficial. For example, an array of a thousand booleans will +take at least 20,000 bytes of space, but it can be turned into one +125-byte bit vector--a considerable memory savings. The standard +Tie::SubstrHash module can also help for certain types of data +structure. If you're working with specialist data structures +(matrices, for instance) modules that implement these in C may use +less memory than equivalent Perl modules. + +Another thing to try is learning whether your Perl was compiled with +the system malloc or with Perl's builtin malloc. Whichever one it +is, try using the other one and see whether this makes a difference. +Information about malloc is in the F<INSTALL> file in the source +distribution. You can find out whether you are using perl's malloc by +typing C<perl -V:usemymalloc>. + +Of course, the best way to save memory is to not do anything to waste +it in the first place. Good programming practices can go a long way +toward this: + +=over 4 + +=item * Don't slurp! + +Don't read an entire file into memory if you can process it line +by line. Or more concretely, use a loop like this: + + # + # Good Idea + # + while (<FILE>) { + # ... + } + +instead of this: + + # + # Bad Idea + # + @data = <FILE>; + foreach (@data) { + # ... + } + +When the files you're processing are small, it doesn't much matter which +way you do it, but it makes a huge difference when they start getting +larger. + +=item * Use map and grep selectively + +Remember that both map and grep expect a LIST argument, so doing this: + + @wanted = grep {/pattern/} <FILE>; + +will cause the entire file to be slurped. For large files, it's better +to loop: + + while (<FILE>) { + push(@wanted, $_) if /pattern/; + } + +=item * Avoid unnecessary quotes and stringification + +Don't quote large strings unless absolutely necessary: + + my $copy = "$large_string"; + +makes 2 copies of $large_string (one for $copy and another for the +quotes), whereas + + my $copy = $large_string; + +only makes one copy. + +Ditto for stringifying large arrays: + + { + local $, = "\n"; + print @big_array; + } + +is much more memory-efficient than either + + print join "\n", @big_array; + +or + + { + local $" = "\n"; + print "@big_array"; + } + + +=item * Pass by reference + +Pass arrays and hashes by reference, not by value. For one thing, it's +the only way to pass multiple lists or hashes (or both) in a single +call/return. It also avoids creating a copy of all the contents. This +requires some judgement, however, because any changes will be propagated +back to the original data. If you really want to mangle (er, modify) a +copy, you'll have to sacrifice the memory needed to make one. + +=item * Tie large variables to disk. + +For "big" data stores (i.e. ones that exceed available memory) consider +using one of the DB modules to store it on disk instead of in RAM. This +will incur a penalty in access time, but that's probably better than +causing your hard disk to thrash due to massive swapping. + +=back + +=head2 Is it safe to return a reference to local or lexical data? + +Yes. Perl's garbage collection system takes care of this so +everything works out right. + + sub makeone { + my @a = ( 1 .. 10 ); + return \@a; + } + + for ( 1 .. 10 ) { + push @many, makeone(); + } + + print $many[4][5], "\n"; + + print "@many\n"; + +=head2 How can I free an array or hash so my program shrinks? + +(contributed by Michael Carman) + +You usually can't. Memory allocated to lexicals (i.e. my() variables) +cannot be reclaimed or reused even if they go out of scope. It is +reserved in case the variables come back into scope. Memory allocated +to global variables can be reused (within your program) by using +undef() and/or delete(). + +On most operating systems, memory allocated to a program can never be +returned to the system. That's why long-running programs sometimes re- +exec themselves. Some operating systems (notably, systems that use +mmap(2) for allocating large chunks of memory) can reclaim memory that +is no longer used, but on such systems, perl must be configured and +compiled to use the OS's malloc, not perl's. + +In general, memory allocation and de-allocation isn't something you can +or should be worrying about much in Perl. + +See also "How can I make my Perl program take less memory?" + +=head2 How can I make my CGI script more efficient? + +Beyond the normal measures described to make general Perl programs +faster or smaller, a CGI program has additional issues. It may be run +several times per second. Given that each time it runs it will need +to be re-compiled and will often allocate a megabyte or more of system +memory, this can be a killer. Compiling into C B<isn't going to help +you> because the process start-up overhead is where the bottleneck is. + +There are two popular ways to avoid this overhead. One solution +involves running the Apache HTTP server (available from +http://www.apache.org/ ) with either of the mod_perl or mod_fastcgi +plugin modules. + +With mod_perl and the Apache::Registry module (distributed with +mod_perl), httpd will run with an embedded Perl interpreter which +pre-compiles your script and then executes it within the same address +space without forking. The Apache extension also gives Perl access to +the internal server API, so modules written in Perl can do just about +anything a module written in C can. For more on mod_perl, see +http://perl.apache.org/ + +With the FCGI module (from CPAN) and the mod_fastcgi +module (available from http://www.fastcgi.com/ ) each of your Perl +programs becomes a permanent CGI daemon process. + +Both of these solutions can have far-reaching effects on your system +and on the way you write your CGI programs, so investigate them with +care. + +See http://www.cpan.org/modules/by-category/15_World_Wide_Web_HTML_HTTP_CGI/ . + +=head2 How can I hide the source for my Perl program? + +Delete it. :-) Seriously, there are a number of (mostly +unsatisfactory) solutions with varying levels of "security". + +First of all, however, you I<can't> take away read permission, because +the source code has to be readable in order to be compiled and +interpreted. (That doesn't mean that a CGI script's source is +readable by people on the web, though--only by people with access to +the filesystem.) So you have to leave the permissions at the socially +friendly 0755 level. + +Some people regard this as a security problem. If your program does +insecure things and relies on people not knowing how to exploit those +insecurities, it is not secure. It is often possible for someone to +determine the insecure things and exploit them without viewing the +source. Security through obscurity, the name for hiding your bugs +instead of fixing them, is little security indeed. + +You can try using encryption via source filters (Starting from Perl +5.8 the Filter::Simple and Filter::Util::Call modules are included in +the standard distribution), but any decent programmer will be able to +decrypt it. You can try using the byte code compiler and interpreter +described later in L<perlfaq3>, but the curious might still be able to +de-compile it. You can try using the native-code compiler described +later, but crackers might be able to disassemble it. These pose +varying degrees of difficulty to people wanting to get at your code, +but none can definitively conceal it (true of every language, not just +Perl). + +It is very easy to recover the source of Perl programs. You simply +feed the program to the perl interpreter and use the modules in +the B:: hierarchy. The B::Deparse module should be able to +defeat most attempts to hide source. Again, this is not +unique to Perl. + +If you're concerned about people profiting from your code, then the +bottom line is that nothing but a restrictive license will give you +legal security. License your software and pepper it with threatening +statements like "This is unpublished proprietary software of XYZ Corp. +Your access to it does not give you permission to use it blah blah +blah." We are not lawyers, of course, so you should see a lawyer if +you want to be sure your license's wording will stand up in court. + +=head2 How can I compile my Perl program into byte code or C? + +(contributed by brian d foy) + +In general, you can't do this. There are some things that may work +for your situation though. People usually ask this question +because they want to distribute their works without giving away +the source code, and most solutions trade disk space for convenience. +You probably won't see much of a speed increase either, since most +solutions simply bundle a Perl interpreter in the final product +(but see L<How can I make my Perl program run faster?>). + +The Perl Archive Toolkit ( http://par.perl.org/ ) is Perl's +analog to Java's JAR. It's freely available and on CPAN ( +http://search.cpan.org/dist/PAR/ ). + +There are also some commercial products that may work for you, although +you have to buy a license for them. + +The Perl Dev Kit ( http://www.activestate.com/Products/Perl_Dev_Kit/ ) +from ActiveState can "Turn your Perl programs into ready-to-run +executables for HP-UX, Linux, Solaris and Windows." + +Perl2Exe ( http://www.indigostar.com/perl2exe.htm ) is a command line +program for converting perl scripts to executable files. It targets both +Windows and unix platforms. + +=head2 How can I get C<#!perl> to work on [MS-DOS,NT,...]? + +For OS/2 just use + + extproc perl -S -your_switches + +as the first line in C<*.cmd> file (C<-S> due to a bug in cmd.exe's +"extproc" handling). For DOS one should first invent a corresponding +batch file and codify it in C<ALTERNATE_SHEBANG> (see the +F<dosish.h> file in the source distribution for more information). + +The Win95/NT installation, when using the ActiveState port of Perl, +will modify the Registry to associate the C<.pl> extension with the +perl interpreter. If you install another port, perhaps even building +your own Win95/NT Perl from the standard sources by using a Windows port +of gcc (e.g., with cygwin or mingw32), then you'll have to modify +the Registry yourself. In addition to associating C<.pl> with the +interpreter, NT people can use: C<SET PATHEXT=%PATHEXT%;.PL> to let them +run the program C<install-linux.pl> merely by typing C<install-linux>. + +Under "Classic" MacOS, a perl program will have the appropriate Creator and +Type, so that double-clicking them will invoke the MacPerl application. +Under Mac OS X, clickable apps can be made from any C<#!> script using Wil +Sanchez' DropScript utility: http://www.wsanchez.net/software/ . + +I<IMPORTANT!>: Whatever you do, PLEASE don't get frustrated, and just +throw the perl interpreter into your cgi-bin directory, in order to +get your programs working for a web server. This is an EXTREMELY big +security risk. Take the time to figure out how to do it correctly. + +=head2 Can I write useful Perl programs on the command line? + +Yes. Read L<perlrun> for more information. Some examples follow. +(These assume standard Unix shell quoting rules.) + + # sum first and last fields + perl -lane 'print $F[0] + $F[-1]' * + + # identify text files + perl -le 'for(@ARGV) {print if -f && -T _}' * + + # remove (most) comments from C program + perl -0777 -pe 's{/\*.*?\*/}{}gs' foo.c + + # make file a month younger than today, defeating reaper daemons + perl -e '$X=24*60*60; utime(time(),time() + 30 * $X,@ARGV)' * + + # find first unused uid + perl -le '$i++ while getpwuid($i); print $i' + + # display reasonable manpath + echo $PATH | perl -nl -072 -e ' + s![^/+]*$!man!&&-d&&!$s{$_}++&&push@m,$_;END{print"@m"}' + +OK, the last one was actually an Obfuscated Perl Contest entry. :-) + +=head2 Why don't Perl one-liners work on my DOS/Mac/VMS system? + +The problem is usually that the command interpreters on those systems +have rather different ideas about quoting than the Unix shells under +which the one-liners were created. On some systems, you may have to +change single-quotes to double ones, which you must I<NOT> do on Unix +or Plan9 systems. You might also have to change a single % to a %%. + +For example: + + # Unix (including Mac OS X) + perl -e 'print "Hello world\n"' + + # DOS, etc. + perl -e "print \"Hello world\n\"" + + # Mac Classic + print "Hello world\n" + (then Run "Myscript" or Shift-Command-R) + + # MPW + perl -e 'print "Hello world\n"' + + # VMS + perl -e "print ""Hello world\n""" + +The problem is that none of these examples are reliable: they depend on the +command interpreter. Under Unix, the first two often work. Under DOS, +it's entirely possible that neither works. If 4DOS was the command shell, +you'd probably have better luck like this: + + perl -e "print <Ctrl-x>"Hello world\n<Ctrl-x>"" + +Under the Mac, it depends which environment you are using. The MacPerl +shell, or MPW, is much like Unix shells in its support for several +quoting variants, except that it makes free use of the Mac's non-ASCII +characters as control characters. + +Using qq(), q(), and qx(), instead of "double quotes", 'single +quotes', and `backticks`, may make one-liners easier to write. + +There is no general solution to all of this. It is a mess. + +[Some of this answer was contributed by Kenneth Albanowski.] + +=head2 Where can I learn about CGI or Web programming in Perl? + +For modules, get the CGI or LWP modules from CPAN. For textbooks, +see the two especially dedicated to web stuff in the question on +books. For problems and questions related to the web, like "Why +do I get 500 Errors" or "Why doesn't it run from the browser right +when it runs fine on the command line", see the troubleshooting +guides and references in L<perlfaq9> or in the CGI MetaFAQ: + + http://www.perl.org/CGI_MetaFAQ.html + +=head2 Where can I learn about object-oriented Perl programming? + +A good place to start is L<perltoot>, and you can use L<perlobj>, +L<perlboot>, L<perltoot>, L<perltooc>, and L<perlbot> for reference. + +A good book on OO on Perl is the "Object-Oriented Perl" +by Damian Conway from Manning Publications, or "Intermediate Perl" +by Randal Schwartz, brian d foy, and Tom Phoenix from O'Reilly Media. + +=head2 Where can I learn about linking C with Perl? + +If you want to call C from Perl, start with L<perlxstut>, +moving on to L<perlxs>, L<xsubpp>, and L<perlguts>. If you want to +call Perl from C, then read L<perlembed>, L<perlcall>, and +L<perlguts>. Don't forget that you can learn a lot from looking at +how the authors of existing extension modules wrote their code and +solved their problems. + +You might not need all the power of XS. The Inline::C module lets +you put C code directly in your Perl source. It handles all the +magic to make it work. You still have to learn at least some of +the perl API but you won't have to deal with the complexity of the +XS support files. + +=head2 I've read perlembed, perlguts, etc., but I can't embed perl in my C program; what am I doing wrong? + +Download the ExtUtils::Embed kit from CPAN and run `make test'. If +the tests pass, read the pods again and again and again. If they +fail, see L<perlbug> and send a bug report with the output of +C<make test TEST_VERBOSE=1> along with C<perl -V>. + +=head2 When I tried to run my script, I got this message. What does it mean? + +A complete list of Perl's error messages and warnings with explanatory +text can be found in L<perldiag>. You can also use the splain program +(distributed with Perl) to explain the error messages: + + perl program 2>diag.out + splain [-v] [-p] diag.out + +or change your program to explain the messages for you: + + use diagnostics; + +or + + use diagnostics -verbose; + +=head2 What's MakeMaker? + +(contributed by brian d foy) + +The C<ExtUtils::MakeMaker> module, better known simply as "MakeMaker", +turns a Perl script, typically called C<Makefile.PL>, into a Makefile. +The unix tool C<make> uses this file to manage dependencies and actions +to process and install a Perl distribution. + +=head1 REVISION + +Revision: $Revision$ + +Date: $Date$ + +See L<perlfaq> for source control details and availability. + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997-2009 Tom Christiansen, Nathan Torkington, and +other authors as noted. All rights reserved. + +This documentation is free; you can redistribute it and/or modify it +under the same terms as Perl itself. + +Irrespective of its distribution, all code examples here are in the public +domain. You are permitted and encouraged to use this code and any +derivatives thereof in your own programs for fun or for profit as you +see fit. A simple comment in the code giving credit to the FAQ would +be courteous but is not required. diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod index 8d93d3fad6..df813da20c 100644 --- a/pod/perlfaq4.pod +++ b/pod/perlfaq4.pod @@ -1006,7 +1006,7 @@ handle that format, such as C<Text::CSV>, C<Text::CSV_XS>, or C<Text::CSV_PP>. If you want to break apart an entire line of fixed columns, you can use -C<unpack> with the A (ASCII) format. by using a number after the format +C<unpack> with the A (ASCII) format. By using a number after the format specifier, you can denote the column width. See the C<pack> and C<unpack> entries in L<perlfunc> for more details. @@ -1545,7 +1545,7 @@ X<cycle> X<modulus> (contributed by brian d foy) -If you want to cycle through an array endlessy, you can increment the +If you want to cycle through an array endlessly, you can increment the index modulo the number of elements in the array: my @array = qw( a b c ); @@ -2156,7 +2156,7 @@ C<$hash{$key}> will be C<undef> while C<exists $hash{$key}> will return true. This corresponds to (C<$key>, C<undef>) being in the hash. -Pictures help... here's the C<%hash> table: +Pictures help... Here's the C<%hash> table: keys values +------+------+ diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod index d6a72c5a3c..09da5bbd06 100644 --- a/pod/perlfaq5.pod +++ b/pod/perlfaq5.pod @@ -275,6 +275,52 @@ proper text file, so this may report one fewer line than you expect. This assumes no funny games with newline translations. +=head2 How do I delete the last N lines from a file? +X<lines> X<file> + +(contributed by brian d foy) + +The easiest conceptual solution is to count the lines in the +file then start at the beginning and print the number of lines +(minus the last N) to a new file. + +Most often, the real question is how you can delete the last N +lines without making more than one pass over the file, or how to +do it with a lot of copying. The easy concept is the hard reality when +you might have millions of lines in your file. + +One trick is to use C<File::ReadBackwards>, which starts at the end of +the file. That module provides an object that wraps the real filehandle +to make it easy for you to move around the file. Once you get to the +spot you need, you can get the actual filehandle and work with it as +normal. In this case, you get the file position at the end of the last +line you want to keep and truncate the file to that point: + + use File::ReadBackwards; + + my $filename = 'test.txt'; + my $Lines_to_truncate = 2; + + my $bw = File::ReadBackwards->new( $filename ) + or die "Could not read backwards in [$filename]: $!"; + + my $lines_from_end = 0; + until( $bw->eof or $lines_from_end == $Lines_to_truncate ) + { + print "Got: ", $bw->readline; + $lines_from_end++; + } + + truncate( $filename, $bw->tell ); + +The C<File::ReadBackwards> module also has the advantage of setting +the input record separator to a regular expression. + +You can also use the C<Tie::File> module which lets you access +the lines through a tied array. You can use normal array operations +to modify your file, including setting the last index and using +C<splice>. + =head2 How can I use Perl's C<-i> option from within a program? X<-i> X<in-place> @@ -725,7 +771,7 @@ one that doesn't use the shell to do globbing. =head2 Is there a leak/bug in glob()? X<glob> -(conributed by brian d foy) +(contributed by brian d foy) Starting with Perl 5.6.0, C<glob> is implemented internally rather than relying on an external resource. As such, memory issues with @@ -913,17 +959,15 @@ Don't forget them or you'll be quite sorry. =head2 How do I get a file's timestamp in perl? X<timestamp> X<file, timestamp> -If you want to retrieve the time at which the file was last -read, written, or had its meta-data (owner, etc) changed, -you use the B<-A>, B<-M>, or B<-C> file test operations as -documented in L<perlfunc>. These retrieve the age of the -file (measured against the start-time of your program) in -days as a floating point number. Some platforms may not have -all of these times. See L<perlport> for details. To -retrieve the "raw" time in seconds since the epoch, you -would call the stat function, then use localtime(), -gmtime(), or POSIX::strftime() to convert this into -human-readable form. +If you want to retrieve the time at which the file was last read, +written, or had its meta-data (owner, etc) changed, you use the B<-A>, +B<-M>, or B<-C> file test operations as documented in L<perlfunc>. +These retrieve the age of the file (measured against the start-time of +your program) in days as a floating point number. Some platforms may +not have all of these times. See L<perlport> for details. To retrieve +the "raw" time in seconds since the epoch, you would call the stat +function, then use C<localtime()>, C<gmtime()>, or +C<POSIX::strftime()> to convert this into human-readable form. Here's an example: @@ -1124,7 +1168,7 @@ include also support for non-portable systems as well. The very first thing you should do is look into getting the Term::ReadKey extension from CPAN. As we mentioned earlier, it now even has limited support for non-portable (read: not open systems, closed, proprietary, -not POSIX, not Unix, etc) systems. +not POSIX, not Unix, etc.) systems. You should also check out the Frequently Asked Questions list in comp.unix.* for things like this: the answer is essentially the same. diff --git a/pod/perlfaq6.pod b/pod/perlfaq6.pod index ea7dcb315d..2e045defb0 100644 --- a/pod/perlfaq6.pod +++ b/pod/perlfaq6.pod @@ -169,7 +169,7 @@ things can occur out-of-order. Just when you think you've got a pattern that matches your input, someone throws you a curveball. If you'd like to do it the hard way, scratching and clawing your way -toward a right answer but constantly being disappointed, beseiged by +toward a right answer but constantly being disappointed, besieged by bug reports, and weary from the inordinate amount of time you have to spend reinventing a triangular wheel, then there are several things you can try before you give up in frustration: @@ -528,7 +528,7 @@ The regular expression to match the balanced text uses two new (to Perl 5.10) regular expression features. These are covered in L<perlre> and this example is a modified version of one in that documentation. -First, adding the new possesive C<+> to any quantifier finds the +First, adding the new possessive C<+> to any quantifier finds the longest match and does not backtrack. That's important since you want to handle any angle brackets through the recursion, not backtracking. The group C<< [^<>]++ >> finds one or more non-angle brackets without diff --git a/pod/perlfaq7.pod b/pod/perlfaq7.pod index 92e2b14ba1..bc2f4f66e7 100644 --- a/pod/perlfaq7.pod +++ b/pod/perlfaq7.pod @@ -654,7 +654,7 @@ see L<perltoot/"Overridden Methods">. (contributed by brian d foy) Calling a subroutine as C<&foo> with no trailing parentheses ignores -the prototype of C<foo> and passes it the current value of the argumet +the prototype of C<foo> and passes it the current value of the argument list, C<@_>. Here's an example; the C<bar> subroutine calls C<&foo>, which prints what its arguments list: @@ -852,7 +852,7 @@ diagnostics as C<Carp> does, use the C<caller> built-in: By default, your program starts in package C<main>, so you should always be in some package unless someone uses the C<package> built-in with no namespace. See the C<package> entry in L<perlfunc> for the -details of empty packges. +details of empty packages. =head2 How can I comment out a large block of Perl code? diff --git a/pod/perlfaq8.pod b/pod/perlfaq8.pod index 95305249cd..8682b4d45a 100644 --- a/pod/perlfaq8.pod +++ b/pod/perlfaq8.pod @@ -1009,31 +1009,42 @@ perform these actions for you. =head2 How do I find out if I'm running interactively or not? -Good question. Sometimes C<-t STDIN> and C<-t STDOUT> can give clues, -sometimes not. - - if (-t STDIN && -t STDOUT) { - print "Now what? "; - } - -On POSIX systems, you can test whether your own process group matches -the current process group of your controlling terminal as follows: +(contributed by brian d foy) - use POSIX qw/getpgrp tcgetpgrp/; +This is a difficult question to answer, and the best answer is +only a guess. What do you really want to know? If you merely +want to know if one of your filehandles is connected to a terminal, +you can try the C<-t> file test: - # Some POSIX systems, such as Linux, can be - # without a /dev/tty at boot time. - if (!open(TTY, "/dev/tty")) { - print "no tty\n"; - } else { - $tpgrp = tcgetpgrp(fileno(*TTY)); - $pgrp = getpgrp(); - if ($tpgrp == $pgrp) { - print "foreground\n"; - } else { - print "background\n"; + if( -t STDOUT ) { + print "I'm connected to a terminal!\n"; + } + +However, you might be out of luck if you expect that means there is a +real person on the other side. With the C<Expect> module, another +program can pretend to be a person. The program might even come close +to passing the Turing test. + +The C<IO::Interactive> module does the best it can to give you an +answer. Its C<is_interactive> function returns an output filehandle; +that filehandle points to standard output if the module thinks the +session is interactive. Otherwise, the filehandle is a null handle +that simply discards the output: + + use IO::Interactive; + + print { is_interactive } "I might go to standard output!\n"; + +This still doesn't guarantee that a real person is answering your +prompts or reading your output. + +If you want to know how to handle automated testing for your +distribution, you can check the environment. The CPAN +Testers, for instance, set the value of C<AUTOMATED_TESTING>: + + unless( $ENV{AUTOMATED_TESTING} ) { + print "Hello interactive tester!\n"; } - } =head2 How do I timeout a slow event? @@ -1173,50 +1184,44 @@ might not be perl's message. =head2 How do I install a module from CPAN? -The easiest way is to have a module also named CPAN do it for you. -This module comes with perl version 5.004 and later. - - $ perl -MCPAN -e shell - - cpan shell -- CPAN exploration and modules installation (v1.59_54) - ReadLine support enabled - - cpan> install Some::Module - -To manually install the CPAN module, or any well-behaved CPAN module -for that matter, follow these steps: - -=over 4 - -=item 1 - -Unpack the source into a temporary area. +(contributed by brian d foy) -=item 2 +The easiest way is to have a module also named CPAN do it for you by using +the C<cpan> command the comes with Perl. You can give it a list of modules +to install: - perl Makefile.PL + $ cpan IO::Interactive Getopt::Whatever -=item 3 +If you prefer C<CPANPLUS>, it's just as easy: - make + $ cpanp i IO::Interactive Getopt::Whatever + +If you want to install a distribution from the current directory, you can +tell C<CPAN.pm> to install C<.> (the full stop): -=item 4 + $ cpan . - make test +See the documentation for either of those commands to see what else +you can do. -=item 5 +If you want to try to install a distribution by yourself, resolving +all dependencies on your own, you follow one of two possible build +paths. - make install +For distributions that use I<Makefile.PL>: -=back + $ perl Makefile.PL + $ make test install + +For distributions that use I<Build.PL>: -If your version of perl is compiled without dynamic loading, then you -just need to replace step 3 (B<make>) with B<make perl> and you will -get a new F<perl> binary with your extension linked in. + $ perl Build.PL + $ ./Build test + $ ./Build install -See L<ExtUtils::MakeMaker> for more details on building extensions. -See also the next question, "What's the difference between require -and use?". +Some distributions may need to link to libraries or other third-party +code and their build and installation sequences may be more complicated. +Check any I<README> or I<INSTALL> files that you may find. =head2 What's the difference between require and use? @@ -1280,7 +1285,7 @@ You can configure CPAN.pm to automatically use this option too: INSTALL_BASE tells these tools to put your modules into F</mydir/perl/lib/perl5>. See L<How do I add a directory to my include path (@INC) at runtime?> for details on how to run your newly -installed moudles. +installed modules. There is one caveat with INSTALL_BASE, though, since it acts differently than the PREFIX and LIB settings that older versions of diff --git a/pod/perlfaq9.pod b/pod/perlfaq9.pod index 5e3c1f0152..190cd68e71 100644 --- a/pod/perlfaq9.pod +++ b/pod/perlfaq9.pod @@ -22,7 +22,7 @@ http://www.ietf.org/rfc/rfc3875 Other relevant documentation listed in: http://www.perl.org/CGI_MetaFAQ.html These Perl FAQs very selectively cover some CGI issues. However, Perl -programmers are strongly advised to use the CGI.pm module, to take care +programmers are strongly advised to use the C<CGI.pm> module, to take care of the details for them. The similarity between CGI response headers (defined in the CGI @@ -41,9 +41,9 @@ transaction response headers; the HTTP specification calls for records to be terminated with carriage-return and line-feed, i.e ASCII \015\012 written in binary mode. -Using CGI.pm gives excellent platform independence, including EBCDIC -systems. CGI.pm selects an appropriate newline representation -($CGI::CRLF) and sets binmode as appropriate. +Using C<CGI.pm> gives excellent platform independence, including EBCDIC +systems. C<CGI.pm> selects an appropriate newline representation +(C<$CGI::CRLF>) and sets binmode as appropriate. =head2 My CGI script runs from the command line but not the browser. (500 Server Error) @@ -67,8 +67,8 @@ listed in the CGI Meta FAQ: =head2 How can I get better error messages from a CGI program? -Use the CGI::Carp module. It replaces C<warn> and C<die>, plus the -normal Carp modules C<carp>, C<croak>, and C<confess> functions with +Use the C<CGI::Carp> module. It replaces C<warn> and C<die>, plus the +normal C<Carp> modules C<carp>, C<croak>, and C<confess> functions with more verbose and safer versions. It still sends them to the normal server error log. @@ -76,8 +76,8 @@ server error log. warn "This is a complaint"; die "But this one is serious"; -The following use of CGI::Carp also redirects errors to a file of your choice, -placed in a BEGIN block to catch compile-time warnings as well: +The following use of C<CGI::Carp> also redirects errors to a file of your choice, +placed in a C<BEGIN> block to catch compile-time warnings as well: BEGIN { use CGI::Carp qw(carpout); @@ -100,9 +100,9 @@ stamp prepended. =head2 How do I remove HTML from a string? -The most correct way (albeit not the fastest) is to use HTML::Parser +The most correct way (albeit not the fastest) is to use C<HTML::Parser> from CPAN. Another mostly correct -way is to use HTML::FormatText which not only removes HTML but also +way is to use C<HTML::FormatText> which not only removes HTML but also attempts to do a little simple formatting of the resulting plain text. Many folks attempt a simple-minded regular expression approach, like @@ -154,7 +154,7 @@ C<HTML::LinkExtor> or C<HTML::Parser>. You might even use C<HTML::SimpleLinkExtor> as an example for something specifically suited to your needs. -You can use URI::Find to extract URLs from an arbitrary text document. +You can use C<URI::Find> to extract URLs from an arbitrary text document. Less complete solutions involving regular expressions can save you a lot of processing time if you know that the input is simple. One @@ -176,20 +176,20 @@ In this case, download means to use the file upload feature of HTML forms. You allow the web surfer to specify a file to send to your web server. To you it looks like a download, and to the user it looks like an upload. No matter what you call it, you do it with what's -known as B<multipart/form-data> encoding. The CGI.pm module (which +known as B<multipart/form-data> encoding. The C<CGI.pm> module (which comes with Perl as part of the Standard Library) supports this in the -start_multipart_form() method, which isn't the same as the startform() +C<start_multipart_form()> method, which isn't the same as the C<startform()> method. -See the section in the CGI.pm documentation on file uploads for code +See the section in the C<CGI.pm> documentation on file uploads for code examples and details. =head2 How do I make an HTML pop-up menu with Perl? (contributed by brian d foy) -The CGI.pm module (which comes with Perl) has functions to create -the HTML form widgets. See the CGI.pm documentation for more +The C<CGI.pm> module (which comes with Perl) has functions to create +the HTML form widgets. See the C<CGI.pm> documentation for more examples. use CGI qw/:standard/; @@ -307,7 +307,7 @@ script. The other kind (an absolute URLpath) is resolved internally to the server without any HTTP redirection. The CGI specifications do not allow relative URLs in either case. -Use of CGI.pm is strongly recommended. This example shows redirection +Use of C<CGI.pm> is strongly recommended. This example shows redirection with a complete URL. This redirection is handled by the web browser. use CGI qw/:standard/; @@ -338,10 +338,10 @@ the details for your particular server. =head2 How do I edit my .htpasswd and .htgroup files with Perl? -The HTTPD::UserAdmin and HTTPD::GroupAdmin modules provide a +The C<HTTPD::UserAdmin> and C<HTTPD::GroupAdmin> modules provide a consistent OO interface to these files, regardless of how they're stored. Databases may be text, dbm, Berkeley DB or any database with -a DBI compatible driver. HTTPD::UserAdmin supports files used by the +a DBI compatible driver. C<HTTPD::UserAdmin> supports files used by the "Basic" and "Digest" authentication schemes. Here's an example: use HTTPD::UserAdmin (); @@ -367,20 +367,20 @@ from L<perlfunc/split>: That solution doesn't do well if, for example, you're trying to maintain all the Received lines. A more complete approach is to use -the Mail::Header module from CPAN (part of the MailTools package). +the C<Mail::Header> module from CPAN (part of the C<MailTools> package). =head2 How do I decode a CGI form? (contributed by brian d foy) -Use the CGI.pm module that comes with Perl. It's quick, +Use the C<CGI.pm> module that comes with Perl. It's quick, it's easy, and it actually does quite a bit of work to ensure things happen correctly. It handles GET, POST, and HEAD requests, multipart forms, multivalued fields, query string and message body combinations, and many other things you probably don't want to think about. -It doesn't get much easier: the CGI module automatically +It doesn't get much easier: the C<CGI.pm> module automatically parses the input and makes each value available through the C<param()> function. @@ -390,7 +390,7 @@ C<param()> function. my @items = param( 'item' ); # multiple values, same field name -If you want an object-oriented approach, CGI.pm can do that too. +If you want an object-oriented approach, C<CGI.pm> can do that too. use CGI; @@ -400,7 +400,7 @@ If you want an object-oriented approach, CGI.pm can do that too. my @items = $cgi->param( 'item' ); -You might also try CGI::Minimal which is a lightweight version +You might also try C<CGI::Minimal> which is a lightweight version of the same thing. Other CGI::* modules on CPAN might work better for you, too. @@ -464,7 +464,7 @@ with the characters reversed, one added or subtracted to each digit, etc. =head2 How do I decode a MIME/BASE64 string? -The MIME-Base64 package (available from CPAN) handles this as well as +The C<MIME-Base64> package (available from CPAN) handles this as well as the MIME/QP encoding. Decoding BASE64 becomes as simple as: use MIME::Base64; @@ -475,7 +475,7 @@ decoding of BASE64 encoded attachments and content directly from email messages. If the string to decode is short (less than 84 bytes long) -a more direct approach is to use the unpack() function's "u" +a more direct approach is to use the C<unpack()> function's "u" format after minor transliterations: tr#A-Za-z0-9+/##cd; # remove non-base64 chars @@ -485,8 +485,8 @@ format after minor transliterations: =head2 How do I return the user's mail address? -On systems that support getpwuid, the $< variable, and the -Sys::Hostname module (which is part of the standard perl distribution), +On systems that support getpwuid, the C<< $< >> variable, and the +C<Sys::Hostname> module (which is part of the standard perl distribution), you can probably try using something like this: use Sys::Hostname; @@ -497,8 +497,8 @@ that the company's mail system will not accept, so you should ask for users' mail addresses when this matters. Furthermore, not all systems on which Perl runs are so forthcoming with this information as is Unix. -The Mail::Util module from CPAN (part of the MailTools package) provides a -mailaddress() function that tries to guess the mail address of the user. +The C<Mail::Util> module from CPAN (part of the MailTools package) provides a +C<mailaddress()> function that tries to guess the mail address of the user. It makes a more intelligent guess than the code above, using information given when the module was installed, but it could still be incorrect. Again, the best way is often just to ask the user. @@ -544,14 +544,14 @@ Or you might be able use the CPAN module Mail::Mailer: print $mailer $body; $mailer->close(); -The Mail::Internet module uses Net::SMTP which is less Unix-centric than -Mail::Mailer, but less reliable. Avoid raw SMTP commands. There +The C<Mail::Internet> module uses C<Net::SMTP> which is less Unix-centric than +C<Mail::Mailer>, but less reliable. Avoid raw SMTP commands. There are many reasons to use a mail transport agent like sendmail. These include queuing, MX records, and security. =head2 How do I use MIME to make an attachment to a mail message? -This answer is extracted directly from the MIME::Lite documentation. +This answer is extracted directly from the C<MIME::Lite> documentation. Create a multipart message (i.e., one with attachments). use MIME::Lite; @@ -576,7 +576,7 @@ Create a multipart message (i.e., one with attachments). $text = $msg->as_string; -MIME::Lite also includes a method for sending these things. +C<MIME::Lite> also includes a method for sending these things. $msg->send; @@ -585,9 +585,9 @@ SMTP via L<Net::SMTP>. =head2 How do I read mail? -While you could use the Mail::Folder module from CPAN (part of the -MailFolder package) or the Mail::Internet module from CPAN (part -of the MailTools package), often a module is overkill. Here's a +While you could use the C<Mail::Folder> module from CPAN (part of the +C<MailFolder> package) or the C<Mail::Internet> module from CPAN (part +of the C<MailTools> package), often a module is overkill. Here's a mail sorter. #!/usr/bin/perl @@ -621,7 +621,7 @@ gethostbyname, Socket, Net::Domain, Sys::Hostname> (contributed by brian d foy) -The Net::Domain module, which is part of the standard distribution starting +The C<Net::Domain> module, which is part of the standard distribution starting in perl5.7.3, can get you the fully qualified domain name (FQDN), the host name, or the domain name. @@ -649,7 +649,7 @@ from the <Socket> module, which also comes with perl. =head2 How do I fetch a news article or the active newsgroups? -Use the Net::NNTP or News::NNTPClient modules, both available from CPAN. +Use the C<Net::NNTP> or C<News::NNTPClient> modules, both available from CPAN. This can make tasks like fetching the newsgroup list as simple as perl -MNews::NNTPClient @@ -657,7 +657,7 @@ This can make tasks like fetching the newsgroup list as simple as =head2 How do I fetch/put an FTP file? -LWP::Simple (available from CPAN) can fetch but not put. Net::FTP (also +C<LWP::Simple> (available from CPAN) can fetch but not put. C<Net::FTP> (also available from CPAN) is more complex but can put as well as fetch. =head2 How can I do RPC in Perl? diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index c440faa410..540b7233f3 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -37,11 +37,11 @@ operator or unary operator, and precedence does matter. And whitespace between the function and left parenthesis doesn't count--so you need to be careful sometimes: - print 1+2+4; # Prints 7. - print(1+2) + 4; # Prints 3. - print (1+2)+4; # Also prints 3! - print +(1+2)+4; # Prints 7. - print ((1+2)+4); # Prints 7. + print 1+2+4; # Prints 7. + print(1+2) + 4; # Prints 3. + print (1+2)+4; # Also prints 3! + print +(1+2)+4; # Prints 7. + print ((1+2)+4); # Prints 7. If you run Perl with the B<-w> switch it can warn you about this. For example, the third line above produces: @@ -86,6 +86,14 @@ which return C<-1> on failure. Exceptions to this rule are C<wait>, C<waitpid>, and C<syscall>. System calls also set the special C<$!> variable on failure. Other functions do not, except accidentally. +Extension modules can also hook into the Perl parser to define new +kinds of keyword-headed expression. These may look like functions, but +may also look completely different. The syntax following the keyword +is defined entirely by the extension. If you are an implementor, see +L<perlapi/PL_keyword_plugin> for the mechanism. If you are using such +a module, see the module's documentation for details of the syntax that +it defines. + =head2 Perl Functions by Category X<function> @@ -299,46 +307,46 @@ the undefined value if the file doesn't exist. Despite the funny names, precedence is the same as any other named unary operator. The operator may be any of: - -r File is readable by effective uid/gid. - -w File is writable by effective uid/gid. - -x File is executable by effective uid/gid. - -o File is owned by effective uid. + -r File is readable by effective uid/gid. + -w File is writable by effective uid/gid. + -x File is executable by effective uid/gid. + -o File is owned by effective uid. - -R File is readable by real uid/gid. - -W File is writable by real uid/gid. - -X File is executable by real uid/gid. - -O File is owned by real uid. + -R File is readable by real uid/gid. + -W File is writable by real uid/gid. + -X File is executable by real uid/gid. + -O File is owned by real uid. - -e File exists. - -z File has zero size (is empty). - -s File has nonzero size (returns size in bytes). + -e File exists. + -z File has zero size (is empty). + -s File has nonzero size (returns size in bytes). - -f File is a plain file. - -d File is a directory. - -l File is a symbolic link. - -p File is a named pipe (FIFO), or Filehandle is a pipe. - -S File is a socket. - -b File is a block special file. - -c File is a character special file. - -t Filehandle is opened to a tty. + -f File is a plain file. + -d File is a directory. + -l File is a symbolic link. + -p File is a named pipe (FIFO), or Filehandle is a pipe. + -S File is a socket. + -b File is a block special file. + -c File is a character special file. + -t Filehandle is opened to a tty. - -u File has setuid bit set. - -g File has setgid bit set. - -k File has sticky bit set. + -u File has setuid bit set. + -g File has setgid bit set. + -k File has sticky bit set. - -T File is an ASCII text file (heuristic guess). - -B File is a "binary" file (opposite of -T). + -T File is an ASCII text file (heuristic guess). + -B File is a "binary" file (opposite of -T). - -M Script start time minus file modification time, in days. - -A Same for access time. - -C Same for inode change time (Unix, may differ for other platforms) + -M Script start time minus file modification time, in days. + -A Same for access time. + -C Same for inode change time (Unix, may differ for other platforms) Example: while (<>) { - chomp; - next unless -f $_; # ignore specials - #... + chomp; + next unless -f $_; # ignore specials + #... } The interpretation of the file permission operators C<-r>, C<-R>, @@ -467,17 +475,17 @@ restart system calls on some systems. Using C<eval>/C<die> always works, modulo the caveats given in L<perlipc/"Signals">. eval { - local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required - alarm $timeout; - $nread = sysread SOCKET, $buffer, $size; - alarm 0; + local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required + alarm $timeout; + $nread = sysread SOCKET, $buffer, $size; + alarm 0; }; if ($@) { - die unless $@ eq "alarm\n"; # propagate unexpected errors - # timed out + die unless $@ eq "alarm\n"; # propagate unexpected errors + # timed out } else { - # didn't + # didn't } For more information see L<perlipc>. @@ -749,9 +757,9 @@ remove anything. If VARIABLE is omitted, it chomps C<$_>. Example: while (<>) { - chomp; # avoid \n on last field - @array = split(/:/); - # ... + chomp; # avoid \n on last field + @array = split(/:/); + # ... } If VARIABLE is a hash, it chomps the hash's values, but not its keys. @@ -819,9 +827,9 @@ Here's an example that looks up nonnumeric uids in the passwd file: chomp($pattern = <STDIN>); ($login,$pass,$uid,$gid) = getpwnam($user) - or die "$user not in passwd file"; + or die "$user not in passwd file"; - @ary = glob($pattern); # expand filenames + @ary = glob($pattern); # expand filenames chown $uid, $gid, @ary; On most systems, you are not allowed to change the ownership of the @@ -901,11 +909,11 @@ Example: open(OUTPUT, '|sort >foo') # pipe to sort or die "Can't start sort: $!"; - #... # print stuff to output - close OUTPUT # wait for sort to finish + #... # print stuff to output + close OUTPUT # wait for sort to finish or warn $! ? "Error closing sort pipe: $!" : "Exit status $? from sort"; - open(INPUT, 'foo') # get sort's results + open(INPUT, 'foo') # get sort's results or die "Can't open 'foo' for input: $!"; FILEHANDLE may be an expression whose value can be used as an indirect @@ -944,12 +952,12 @@ the main block. So will C<next>, but since it will execute a C<continue> block, it may be more entertaining. while (EXPR) { - ### redo always comes here - do_something; + ### redo always comes here + do_something; } continue { - ### next always comes here - do_something_else; - # then back the top to re-check EXPR + ### next always comes here + do_something_else; + # then back the top to re-check EXPR } ### last always comes here @@ -1036,9 +1044,9 @@ their password: system "stty echo"; if (crypt($word, $pwd) ne $pwd) { - die "Sorry...\n"; + die "Sorry...\n"; } else { - print "ok\n"; + print "ok\n"; } Of course, typing in your own password to whoever asks you @@ -1090,7 +1098,7 @@ function to iterate over large DBM files. Example: # print out history file offsets dbmopen(%HIST,'/usr/lib/news/history',0666); while (($key,$val) = each %HIST) { - print $key, ' = ', unpack('L',$val), "\n"; + print $key, ' = ', unpack('L',$val), "\n"; } dbmclose(%HIST); @@ -1103,7 +1111,7 @@ before you call dbmopen(): use DB_File; dbmopen(%NS_Hist, "$ENV{HOME}/.netscape/history.db") - or die "Can't open netscape history file: $!"; + or die "Can't open netscape history file: $!"; =item defined EXPR X<defined> X<undef> X<undefined> @@ -1148,7 +1156,7 @@ Examples: print if defined $switch{'D'}; print "$val\n" while defined($val = pop(@ary)); die "Can't readlink $sym: $!" - unless defined($value = readlink $sym); + unless defined($value = readlink $sym); sub foo { defined &$bar ? &$bar(@_) : die "No bar"; } $debugging = 0 unless defined $debugging; @@ -1202,11 +1210,11 @@ after them down. Use splice() for that. See L</exists>. The following (inefficiently) deletes all the values of %HASH and @ARRAY: foreach $key (keys %HASH) { - delete $HASH{$key}; + delete $HASH{$key}; } foreach $index (0 .. $#ARRAY) { - delete $ARRAY[$index]; + delete $ARRAY[$index]; } And so do these: @@ -1218,11 +1226,11 @@ And so do these: But both of these are slower than just assigning the empty list or undefining %HASH or @ARRAY: - %HASH = (); # completely empty %HASH - undef %HASH; # forget %HASH ever existed + %HASH = (); # completely empty %HASH + undef %HASH; # forget %HASH ever existed - @ARRAY = (); # completely empty @ARRAY - undef @ARRAY; # forget @ARRAY ever existed + @ARRAY = (); # completely empty @ARRAY + undef @ARRAY; # forget @ARRAY ever existed Note that the EXPR can be arbitrarily complicated as long as the final operation is a hash element, array element, hash slice, or array slice @@ -1328,7 +1336,7 @@ currently the case--the C<$SIG{__DIE__}> hook is currently called even inside eval()ed blocks/strings! If one wants the hook to do nothing in such situations, put - die @_ if $^S; + die @_ if $^S; as the first line of the handler (see L<perlvar/$^S>). Because this promotes strange action at a distance, this counterintuitive @@ -1388,12 +1396,12 @@ file. Manual error checking can be done this way: # read in config files: system first, then user for $file ("/share/prog/defaults.rc", "$ENV{HOME}/.someprogrc") - { - unless ($return = do $file) { - warn "couldn't parse $file: $@" if $@; - warn "couldn't do $file: $!" unless defined $return; - warn "couldn't run $file" unless $return; - } + { + unless ($return = do $file) { + warn "couldn't parse $file: $@" if $@; + warn "couldn't do $file: $!" unless defined $return; + warn "couldn't run $file" unless $return; + } } =item dump LABEL @@ -1460,7 +1468,7 @@ The following prints out your environment like the printenv(1) program, only in a different order: while (($key,$value) = each %ENV) { - print "$key=$value\n"; + print "$key=$value\n"; } See also C<keys>, C<values> and C<sort>. @@ -1499,19 +1507,19 @@ last file. Examples: # reset line numbering on each input file while (<>) { - next if /^\s*#/; # skip comments - print "$.\t$_"; + next if /^\s*#/; # skip comments + print "$.\t$_"; } continue { - close ARGV if eof; # Not eof()! + close ARGV if eof; # Not eof()! } # insert dashes just before last line of last file while (<>) { - if (eof()) { # check for end of last file - print "--------------\n"; - } - print; - last if eof(); # needed if we're reading from a terminal + if (eof()) { # check for end of last file + print "--------------\n"; + } + print; + last if eof(); # needed if we're reading from a terminal } Practical hint: you almost never need to use C<eof> in Perl, because the @@ -1583,10 +1591,10 @@ Examples: eval '$answer = $a / $b'; warn $@ if $@; # a compile-time error - eval { $answer = }; # WRONG + eval { $answer = }; # WRONG # a run-time error - eval '$answer ='; # sets $@ + eval '$answer ='; # sets $@ Using the C<eval{}> form as an exception trap in libraries does have some issues. Due to the current arguably broken state of C<__DIE__> hooks, you @@ -1615,14 +1623,14 @@ may be fixed in a future release. With an C<eval>, you should be especially careful to remember what's being looked at when: - eval $x; # CASE 1 - eval "$x"; # CASE 2 + eval $x; # CASE 1 + eval "$x"; # CASE 2 - eval '$x'; # CASE 3 - eval { $x }; # CASE 4 + eval '$x'; # CASE 3 + eval { $x }; # CASE 4 - eval "\$$x++"; # CASE 5 - $$x++; # CASE 6 + eval "\$$x++"; # CASE 5 + $$x++; # CASE 6 Cases 1 and 2 above behave identically: they run the code contained in the variable $x. (Although case 2 has misleading double quotes making @@ -1699,11 +1707,11 @@ LIST as a multivalued list, even if there is only a single scalar in the list.) Example: $shell = '/bin/csh'; - exec $shell '-sh'; # pretend it's a login shell + exec $shell '-sh'; # pretend it's a login shell or, more directly, - exec {'/bin/csh'} '-sh'; # pretend it's a login shell + exec {'/bin/csh'} '-sh'; # pretend it's a login shell When the arguments get executed via the system shell, results will be subject to its quirks and capabilities. See L<perlop/"`STRING`"> @@ -1742,12 +1750,12 @@ Given an expression that specifies a hash element or array element, returns true if the specified element in the hash or array has ever been initialized, even if the corresponding value is undefined. - print "Exists\n" if exists $hash{$key}; - print "Defined\n" if defined $hash{$key}; + print "Exists\n" if exists $hash{$key}; + print "Defined\n" if defined $hash{$key}; print "True\n" if $hash{$key}; - print "Exists\n" if exists $array[$index]; - print "Defined\n" if defined $array[$index]; + print "Exists\n" if exists $array[$index]; + print "Defined\n" if defined $array[$index]; print "True\n" if $array[$index]; A hash or array element can be true only if it's defined, and defined if @@ -1761,17 +1769,17 @@ exist may still be callable: its package may have an C<AUTOLOAD> method that makes it spring into existence the first time that it is called -- see L<perlsub>. - print "Exists\n" if exists &subroutine; - print "Defined\n" if defined &subroutine; + print "Exists\n" if exists &subroutine; + print "Defined\n" if defined &subroutine; Note that the EXPR can be arbitrarily complicated as long as the final operation is a hash or array key lookup or subroutine name: - if (exists $ref->{A}->{B}->{$key}) { } - if (exists $hash{A}{B}{$key}) { } + if (exists $ref->{A}->{B}->{$key}) { } + if (exists $hash{A}{B}{$key}) { } - if (exists $ref->{A}->{B}->[$ix]) { } - if (exists $hash{A}{B}[$ix]) { } + if (exists $ref->{A}->{B}->[$ix]) { } + if (exists $hash{A}{B}[$ix]) { } if (exists &{$ref->{A}{B}{$key}}) { } @@ -1782,8 +1790,8 @@ into existence due to the existence test for the $key element above. This happens anywhere the arrow operator is used, including even: undef $ref; - if (exists $ref->{"Some key"}) { } - print $ref; # prints HASH(0x80d3d5c) + if (exists $ref->{"Some key"}) { } + print $ref; # prints HASH(0x80d3d5c) This surprising autovivification in what does not at first--or even second--glance appear to be an lvalue context may be fixed in a future @@ -1792,8 +1800,8 @@ release. Use of a subroutine call, rather than a subroutine name, as an argument to exists() is an error. - exists ⊂ # OK - exists &sub(); # Error + exists ⊂ # OK + exists &sub(); # Error =item exit EXPR X<exit> X<terminate> X<abort> @@ -1844,7 +1852,7 @@ For example: use Fcntl; fcntl($filehandle, F_GETFL, $packed_return_buffer) - or die "can't fcntl F_GETFL: $!"; + or die "can't fcntl F_GETFL: $!"; You don't have to check for C<defined> on the return from C<fcntl>. Like C<ioctl>, it maps a C<0> return from the system call into @@ -1881,7 +1889,7 @@ You can use this to find out whether two handles refer to the same underlying descriptor: if (fileno(THIS) == fileno(THAT)) { - print "THIS and THAT are dups\n"; + print "THIS and THAT are dups\n"; } (Filehandles connected to memory objects via new features of C<open> may @@ -1943,20 +1951,20 @@ Here's a mailbox appender for BSD systems. use Fcntl qw(:flock SEEK_END); # import LOCK_* and SEEK_END constants sub lock { - my ($fh) = @_; - flock($fh, LOCK_EX) or die "Cannot lock mailbox - $!\n"; + my ($fh) = @_; + flock($fh, LOCK_EX) or die "Cannot lock mailbox - $!\n"; - # and, in case someone appended while we were waiting... - seek($fh, 0, SEEK_END) or die "Cannot seek - $!\n"; + # and, in case someone appended while we were waiting... + seek($fh, 0, SEEK_END) or die "Cannot seek - $!\n"; } sub unlock { - my ($fh) = @_; - flock($fh, LOCK_UN) or die "Cannot unlock mailbox - $!\n"; + my ($fh) = @_; + flock($fh, LOCK_UN) or die "Cannot unlock mailbox - $!\n"; } open(my $mbox, ">>", "/usr/spool/mail/$ENV{'USER'}") - or die "Can't open mailbox: $!"; + or die "Can't open mailbox: $!"; lock($mbox); print $mbox $msg,"\n\n"; @@ -2004,8 +2012,8 @@ Declare a picture format for use by the C<write> function. For example: format Something = - Test: @<<<<<<<< @||||| @>>>>> - $str, $%, '$' . int($num) + Test: @<<<<<<<< @||||| @>>>>> + $str, $%, '$' . int($num) . $str = "widget"; @@ -2048,19 +2056,19 @@ used by itself to fetch single characters without waiting for the user to hit enter. For that, try something more like: if ($BSD_STYLE) { - system "stty cbreak </dev/tty >/dev/tty 2>&1"; + system "stty cbreak </dev/tty >/dev/tty 2>&1"; } else { - system "stty", '-icanon', 'eol', "\001"; + system "stty", '-icanon', 'eol', "\001"; } $key = getc(STDIN); if ($BSD_STYLE) { - system "stty -cbreak </dev/tty >/dev/tty 2>&1"; + system "stty -cbreak </dev/tty >/dev/tty 2>&1"; } else { - system "stty", 'icanon', 'eol', '^@'; # ASCII null + system "stty", 'icanon', 'eol', '^@'; # ASCII null } print "\n"; @@ -2333,10 +2341,10 @@ An example testing if Nagle's algorithm is turned on on a socket: use Socket qw(:all); defined(my $tcp = getprotobyname("tcp")) - or die "Could not determine the protocol number for tcp"; + or die "Could not determine the protocol number for tcp"; # my $tcp = IPPROTO_TCP; # Alternative my $packed = getsockopt($socket, $tcp, TCP_NODELAY) - or die "Could not query TCP_NODELAY socket option: $!"; + or die "Could not query TCP_NODELAY socket option: $!"; my $nodelay = unpack("I", $packed); print "Nagle's algorithm is turned ", $nodelay ? "off\n" : "on\n"; @@ -2384,18 +2392,15 @@ X<goto> X<jump> X<jmp> =item goto &NAME -The C<goto-LABEL> form finds the statement labeled with LABEL and resumes -execution there. It may not be used to go into any construct that -requires initialization, such as a subroutine or a C<foreach> loop. It -also can't be used to go into a construct that is optimized away, -or to get out of a block or subroutine given to C<sort>. -It can be used to go almost anywhere else within the dynamic scope, -including out of subroutines, but it's usually better to use some other -construct such as C<last> or C<die>. The author of Perl has never felt the -need to use this form of C<goto> (in Perl, that is--C is another matter). -(The difference being that C does not offer named loops combined with -loop control. Perl does, and this replaces most structured uses of C<goto> -in other languages.) +The C<goto-LABEL> form finds the statement labeled with LABEL and +resumes execution there. It can't be used to get out of a block or +subroutine given to C<sort>. It can be used to go almost anywhere +else within the dynamic scope, including out of subroutines, but it's +usually better to use some other construct such as C<last> or C<die>. +The author of Perl has never felt the need to use this form of C<goto> +(in Perl, that is--C is another matter). (The difference being that C +does not offer named loops combined with loop control. Perl does, and +this replaces most structured uses of C<goto> in other languages.) The C<goto-EXPR> form expects a label name, whose scope will be resolved dynamically. This allows for computed C<goto>s per FORTRAN, but isn't @@ -2403,6 +2408,12 @@ necessarily recommended if you're optimizing for maintainability: goto ("FOO", "BAR", "GLARCH")[$i]; +Use of C<goto-LABEL> or C<goto-EXPR> to jump into a construct is +deprecated and will issue a warning. Even then, it may not be used to +go into any construct that requires initialization, such as a +subroutine or a C<foreach> loop. It also can't be used to go into a +construct that is optimized away. + The C<goto-&NAME> form is quite different from the other forms of C<goto>. In fact, it isn't a goto in the normal sense at all, and doesn't have the stigma associated with other gotos. Instead, it @@ -2513,7 +2524,7 @@ X<ioctl> Implements the ioctl(2) function. You'll probably first have to say - require "sys/ioctl.ph"; # probably in $Config{archlib}/sys/ioctl.ph + require "sys/ioctl.ph"; # probably in $Config{archlib}/sys/ioctl.ph to get the correct function definitions. If F<sys/ioctl.ph> doesn't exist or doesn't have the correct definitions you'll have to roll your @@ -2530,10 +2541,10 @@ C<ioctl>. The return value of C<ioctl> (and C<fcntl>) is as follows: - if OS returns: then Perl returns: - -1 undefined value - 0 string "0 but true" - anything else that number + if OS returns: then Perl returns: + -1 undefined value + 0 string "0 but true" + anything else that number Thus Perl returns true on success and false on failure, yet you can still easily determine the actual value returned by the operating @@ -2581,13 +2592,13 @@ Here is yet another way to print your environment: @keys = keys %ENV; @values = values %ENV; while (@keys) { - print pop(@keys), '=', pop(@values), "\n"; + print pop(@keys), '=', pop(@values), "\n"; } or how about sorted by key: foreach $key (sort(keys %ENV)) { - print $key, '=', $ENV{$key}, "\n"; + print $key, '=', $ENV{$key}, "\n"; } The returned values are copies of the original keys in the hash, so @@ -2597,7 +2608,7 @@ To sort a hash by value, you'll need to use a C<sort> function. Here's a descending numeric sort of a hash by its values: foreach $key (sort { $hash{$b} <=> $hash{$a} } keys %hash) { - printf "%4d %s\n", $hash{$key}, $key; + printf "%4d %s\n", $hash{$key}, $key; } As an lvalue C<keys> allows you to increase the number of hash buckets @@ -2656,8 +2667,8 @@ omitted, the command refers to the innermost enclosing loop. The C<continue> block, if any, is not executed: LINE: while (<STDIN>) { - last LINE if /^$/; # exit when done with header - #... + last LINE if /^$/; # exit when done with header + #... } C<last> cannot be used to exit a block which returns a value such as @@ -2845,8 +2856,8 @@ The base-N log of a number is equal to the natural log of that number divided by the natural log of N. For example: sub log10 { - my $n = shift; - return log($n)/log(10); + my $n = shift; + return log($n)/log(10); } See also L</exp> for the inverse operation. @@ -2890,7 +2901,7 @@ is just a funny way to write %hash = (); foreach (@array) { - $hash{get_a_key_for($_)} = $_; + $hash{get_a_key_for($_)} = $_; } Note that C<$_> is an alias to the list value, so it can be used to @@ -3028,8 +3039,8 @@ The C<next> command is like the C<continue> statement in C; it starts the next iteration of the loop: LINE: while (<STDIN>) { - next LINE if /^#/; # discard comments - #... + next LINE if /^#/; # discard comments + #... } Note that if there were a C<continue> block on the above, it would get @@ -3232,51 +3243,51 @@ Examples: open ARTICLE or die "Can't find article $ARTICLE: $!\n"; while (<ARTICLE>) {... - open(LOG, '>>/usr/spool/news/twitlog'); # (log is reserved) + open(LOG, '>>/usr/spool/news/twitlog'); # (log is reserved) # if the open fails, output is discarded - open(my $dbase, '+<', 'dbase.mine') # open for update - or die "Can't open 'dbase.mine' for update: $!"; + open(my $dbase, '+<', 'dbase.mine') # open for update + or die "Can't open 'dbase.mine' for update: $!"; - open(my $dbase, '+<dbase.mine') # ditto - or die "Can't open 'dbase.mine' for update: $!"; + open(my $dbase, '+<dbase.mine') # ditto + or die "Can't open 'dbase.mine' for update: $!"; - open(ARTICLE, '-|', "caesar <$article") # decrypt article - or die "Can't start caesar: $!"; + open(ARTICLE, '-|', "caesar <$article") # decrypt article + or die "Can't start caesar: $!"; - open(ARTICLE, "caesar <$article |") # ditto - or die "Can't start caesar: $!"; + open(ARTICLE, "caesar <$article |") # ditto + or die "Can't start caesar: $!"; - open(EXTRACT, "|sort >Tmp$$") # $$ is our process id - or die "Can't start sort: $!"; + open(EXTRACT, "|sort >Tmp$$") # $$ is our process id + or die "Can't start sort: $!"; # in memory files open(MEMORY,'>', \$var) - or die "Can't open memory file: $!"; - print MEMORY "foo!\n"; # output will end up in $var + or die "Can't open memory file: $!"; + print MEMORY "foo!\n"; # output will end up in $var # process argument list of files along with any includes foreach $file (@ARGV) { - process($file, 'fh00'); + process($file, 'fh00'); } sub process { - my($filename, $input) = @_; - $input++; # this is a string increment - unless (open($input, $filename)) { - print STDERR "Can't open $filename: $!\n"; - return; - } - - local $_; - while (<$input>) { # note use of indirection - if (/^#include "(.*)"/) { - process($1, $input); - next; - } - #... # whatever - } + my($filename, $input) = @_; + $input++; # this is a string increment + unless (open($input, $filename)) { + print STDERR "Can't open $filename: $!\n"; + return; + } + + local $_; + while (<$input>) { # note use of indirection + if (/^#include "(.*)"/) { + process($1, $input); + next; + } + #... # whatever + } } See L<perliol> for detailed info on PerlIO. @@ -3301,11 +3312,11 @@ C<STDERR> using various methods: open STDOUT, '>', "foo.out" or die "Can't redirect STDOUT: $!"; open STDERR, ">&STDOUT" or die "Can't dup STDOUT: $!"; - select STDERR; $| = 1; # make unbuffered - select STDOUT; $| = 1; # make unbuffered + select STDERR; $| = 1; # make unbuffered + select STDOUT; $| = 1; # make unbuffered - print STDOUT "stdout 1\n"; # this works for - print STDERR "stderr 1\n"; # subprocesses too + print STDOUT "stdout 1\n"; # this works for + print STDERR "stderr 1\n"; # subprocesses too open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!"; open STDERR, ">&OLDERR" or die "Can't dup OLDERR: $!"; @@ -3436,7 +3447,7 @@ another way to protect your filenames from interpretation. For example: use IO::Handle; sysopen(HANDLE, $path, O_RDWR|O_CREAT|O_EXCL) - or die "sysopen $path: $!"; + or die "sysopen $path: $!"; $oldfh = select(HANDLE); $| = 1; select($oldfh); print HANDLE "stuff $$\n"; seek(HANDLE, 0, 0); @@ -3450,14 +3461,14 @@ them, and automatically close whenever and however you leave that scope: use IO::File; #... sub read_myfile_munged { - my $ALL = shift; - my $handle = IO::File->new; - open($handle, "myfile") or die "myfile: $!"; - $first = <$handle> - or return (); # Automatically closed here. - mung $first or die "mung failed"; # Or here. - return $first, <$handle> if $ALL; # Or here. - $first; # Or here. + my $ALL = shift; + my $handle = IO::File->new; + open($handle, "myfile") or die "myfile: $!"; + $first = <$handle> + or return (); # Automatically closed here. + mung $first or die "mung failed"; # Or here. + return $first, <$handle> if $ALL; # Or here. + $first; # Or here. } See L</seek> for some details about mixing reading and writing. @@ -3522,11 +3533,11 @@ of the declaration, not at the point of use. This means the following behavior holds: package Foo; - our $bar; # declares $Foo::bar for rest of lexical scope + our $bar; # declares $Foo::bar for rest of lexical scope $bar = 20; package Bar; - print $bar; # prints 20, as it refers to $Foo::bar + print $bar; # prints 20, as it refers to $Foo::bar Multiple C<our> declarations with the same name in the same lexical scope are allowed if they are in different packages. If they happen @@ -3538,15 +3549,15 @@ merely redundant. use warnings; package Foo; - our $bar; # declares $Foo::bar for rest of lexical scope + our $bar; # declares $Foo::bar for rest of lexical scope $bar = 20; package Bar; - our $bar = 30; # declares $Bar::bar for rest of lexical scope - print $bar; # prints 30 + our $bar = 30; # declares $Bar::bar for rest of lexical scope + print $bar; # prints 30 - our $bar; # emits warning but has no other effect - print $bar; # still prints 30 + our $bar; # emits warning but has no other effect + print $bar; # still prints 30 An C<our> declaration may also have a list of attributes associated with it. @@ -3571,71 +3582,71 @@ converted to a sequence of 4 characters. The TEMPLATE is a sequence of characters that give the order and type of values, as follows: - a A string with arbitrary binary data, will be null padded. - A A text (ASCII) string, will be space padded. - Z A null terminated (ASCIZ) string, will be null padded. + a A string with arbitrary binary data, will be null padded. + A A text (ASCII) string, will be space padded. + Z A null terminated (ASCIZ) string, will be null padded. - b A bit string (ascending bit order inside each byte, like vec()). - B A bit string (descending bit order inside each byte). - h A hex string (low nybble first). - H A hex string (high nybble first). + b A bit string (ascending bit order inside each byte, like vec()). + B A bit string (descending bit order inside each byte). + h A hex string (low nybble first). + H A hex string (high nybble first). - c A signed char (8-bit) value. - C An unsigned char (octet) value. + c A signed char (8-bit) value. + C An unsigned char (octet) value. W An unsigned char value (can be greater than 255). - s A signed short (16-bit) value. - S An unsigned short value. + s A signed short (16-bit) value. + S An unsigned short value. - l A signed long (32-bit) value. - L An unsigned long value. + l A signed long (32-bit) value. + L An unsigned long value. - q A signed quad (64-bit) value. - Q An unsigned quad value. - (Quads are available only if your system supports 64-bit - integer values _and_ if Perl has been compiled to support those. + q A signed quad (64-bit) value. + Q An unsigned quad value. + (Quads are available only if your system supports 64-bit + integer values _and_ if Perl has been compiled to support those. Causes a fatal error otherwise.) - i A signed integer value. - I A unsigned integer value. - (This 'integer' is _at_least_ 32 bits wide. Its exact + i A signed integer value. + I A unsigned integer value. + (This 'integer' is _at_least_ 32 bits wide. Its exact size depends on what a local C compiler calls 'int'.) - n An unsigned short (16-bit) in "network" (big-endian) order. - N An unsigned long (32-bit) in "network" (big-endian) order. - v An unsigned short (16-bit) in "VAX" (little-endian) order. - V An unsigned long (32-bit) in "VAX" (little-endian) order. + n An unsigned short (16-bit) in "network" (big-endian) order. + N An unsigned long (32-bit) in "network" (big-endian) order. + v An unsigned short (16-bit) in "VAX" (little-endian) order. + V An unsigned long (32-bit) in "VAX" (little-endian) order. j A Perl internal signed integer value (IV). J A Perl internal unsigned integer value (UV). - f A single-precision float in the native format. - d A double-precision float in the native format. + f A single-precision float in the native format. + d A double-precision float in the native format. - F A Perl internal floating point value (NV) in the native format - D A long double-precision float in the native format. - (Long doubles are available only if your system supports long - double values _and_ if Perl has been compiled to support those. + F A Perl internal floating point value (NV) in the native format + D A long double-precision float in the native format. + (Long doubles are available only if your system supports long + double values _and_ if Perl has been compiled to support those. Causes a fatal error otherwise.) - p A pointer to a null-terminated string. - P A pointer to a structure (fixed-length string). + p A pointer to a null-terminated string. + P A pointer to a structure (fixed-length string). - u A uuencoded string. - U A Unicode character number. Encodes to a character in character mode + u A uuencoded string. + U A Unicode character number. Encodes to a character in character mode and UTF-8 (or UTF-EBCDIC in EBCDIC platforms) in byte mode. - w A BER compressed integer (not an ASN.1 BER, see perlpacktut for - details). Its bytes represent an unsigned integer in base 128, - most significant digit first, with as few digits as possible. Bit - eight (the high bit) is set on each byte except the last. + w A BER compressed integer (not an ASN.1 BER, see perlpacktut for + details). Its bytes represent an unsigned integer in base 128, + most significant digit first, with as few digits as possible. Bit + eight (the high bit) is set on each byte except the last. - x A null byte. - X Back up a byte. - @ Null fill or truncate to absolute position, counted from the + x A null byte. + X Back up a byte. + @ Null fill or truncate to absolute position, counted from the start of the innermost ()-group. . Null fill or truncate to absolute position specified by value. - ( Start of a ()-group. + ( Start of a ()-group. One or more of the modifiers below may optionally follow some letters in the TEMPLATE (the second column lists the letters for which the modifier is @@ -3832,8 +3843,8 @@ exactly 32 bits, the native C<long> (as seen by the local C compiler) may be larger. This is an issue mainly in 64-bit platforms. You can see whether using C<!> makes any difference by - print length(pack("s")), " ", length(pack("s!")), "\n"; - print length(pack("l")), " ", length(pack("l!")), "\n"; + print length(pack("s")), " ", length(pack("s!")), "\n"; + print length(pack("l")), " ", length(pack("l!")), "\n"; C<i!> and C<I!> also work but only because of completeness; they are identical to C<i> and C<I>. @@ -3859,8 +3870,8 @@ because they obey the native byteorder and endianness. For example a 4-byte integer 0x12345678 (305419896 decimal) would be ordered natively (arranged in and handled by the CPU registers) into bytes as - 0x12 0x34 0x56 0x78 # big-endian - 0x78 0x56 0x34 0x12 # little-endian + 0x12 0x34 0x56 0x78 # big-endian + 0x78 0x56 0x34 0x12 # little-endian Basically, the Intel and VAX CPUs are little-endian, while everybody else, for example Motorola m68k/88k, PPC, Sparc, HP PA, Power, and @@ -3875,19 +3886,19 @@ the egg-eating habits of the Lilliputians. Some systems may have even weirder byte orders such as - 0x56 0x78 0x12 0x34 - 0x34 0x12 0x78 0x56 + 0x56 0x78 0x12 0x34 + 0x34 0x12 0x78 0x56 You can see your system's preference with - print join(" ", map { sprintf "%#02x", $_ } + print join(" ", map { sprintf "%#02x", $_ } unpack("W*",pack("L",0x12345678))), "\n"; The byteorder on the platform where Perl was built is also available via L<Config>: - use Config; - print $Config{byteorder}, "\n"; + use Config; + print $Config{byteorder}, "\n"; Byteorders C<'1234'> and C<'12345678'> are little-endian, C<'4321'> and C<'87654321'> are big-endian. @@ -4058,7 +4069,7 @@ Examples: # "@utmp1" eq "@utmp2" sub bintodec { - unpack("N", pack("B32", substr("0" x 32 . shift, -32))); + unpack("N", pack("B32", substr("0" x 32 . shift, -32))); } $foo = pack('sx2l', 12, 34); @@ -4189,6 +4200,9 @@ you will have to use a block returning the filehandle value instead: print { $files[$i] } "stuff\n"; print { $OK ? STDOUT : STDERR } "stuff\n"; +Printing to a closed pipe or socket will generate a SIGPIPE signal. See +L<perlipc> for more on signal handling. + =item printf FILEHANDLE FORMAT, LIST X<printf> @@ -4228,7 +4242,7 @@ onto the end of ARRAY. The length of ARRAY increases by the length of LIST. Has the same effect as for $value (LIST) { - $ARRAY[++$#ARRAY] = $value; + $ARRAY[++$#ARRAY] = $value; } but is more efficient. Returns the number of elements in the array following @@ -4362,7 +4376,7 @@ operator, but you can use it directly. The C<< <EXPR> >> operator is discussed in more detail in L<perlop/"I/O Operators">. $line = <STDIN>; - $line = readline(*STDIN); # same thing + $line = readline(*STDIN); # same thing If C<readline> encounters an operating system error, C<$!> will be set with the corresponding error message. It can be helpful to check @@ -4370,10 +4384,10 @@ C<$!> when you are reading from filehandles you don't trust, such as a tty or a socket. The following example uses the operator form of C<readline> and dies if the result is not defined. - while ( ! eof($fh) ) { - defined( $_ = <$fh> ) or die "readline failed: $!"; - ... - } + while ( ! eof($fh) ) { + defined( $_ = <$fh> ) or die "readline failed: $!"; + ... + } Note that you have can't handle C<readline> errors that way with the C<ARGV> filehandle. In that case, you have to open each element of @@ -4448,18 +4462,18 @@ normally use this command: # a simpleminded Pascal comment stripper # (warning: assumes no { or } in strings) LINE: while (<STDIN>) { - while (s|({.*}.*){.*}|$1 |) {} - s|{.*}| |; - if (s|{.*| |) { - $front = $_; - while (<STDIN>) { - if (/}/) { # end of comment? - s|^|$front\{|; - redo LINE; - } - } - } - print; + while (s|({.*}.*){.*}|$1 |) {} + s|{.*}| |; + if (s|{.*| |) { + $front = $_; + while (<STDIN>) { + if (/}/) { # end of comment? + s|^|$front\{|; + redo LINE; + } + } + } + print; } C<redo> cannot be used to retry a block which returns a value such as @@ -4500,10 +4514,10 @@ If the referenced object has been blessed into a package, then that package name is returned instead. You can think of C<ref> as a C<typeof> operator. if (ref($r) eq "HASH") { - print "r is a reference to a hash.\n"; + print "r is a reference to a hash.\n"; } unless (ref($r)) { - print "r is not a reference at all.\n"; + print "r is not a reference at all.\n"; } The return value C<LVALUE> indicates a reference to an lvalue that is not @@ -4553,9 +4567,9 @@ avoided, because it leads to misleading error messages under earlier versions of Perl that do not support this syntax. The equivalent numeric version should be used instead. - require v5.6.1; # run time version check - require 5.6.1; # ditto - require 5.006_001; # ditto; preferred for backwards compatibility + require v5.6.1; # run time version check + require 5.6.1; # ditto + require 5.006_001; # ditto; preferred for backwards compatibility Otherwise, C<require> demands that a library file be included if it hasn't already been included. The file is included via the do-FILE @@ -4608,7 +4622,7 @@ modules does not risk altering your namespace. In other words, if you try this: - require Foo::Bar; # a splendid bareword + require Foo::Bar; # a splendid bareword The require function will actually look for the "F<Foo/Bar.pm>" file in the directories specified in the C<@INC> array. @@ -4616,9 +4630,9 @@ directories specified in the C<@INC> array. But if you try this: $class = 'Foo::Bar'; - require $class; # $class is not a bareword + require $class; # $class is not a bareword #or - require "Foo::Bar"; # not a bareword because of the "" + require "Foo::Bar"; # not a bareword because of the "" The require function will look for the "F<Foo::Bar>" file in the @INC array and will complain about not finding "F<Foo::Bar>" there. In this case you can do: @@ -4681,18 +4695,18 @@ In other words, you can write: push @INC, \&my_sub; sub my_sub { - my ($coderef, $filename) = @_; # $coderef is \&my_sub - ... + my ($coderef, $filename) = @_; # $coderef is \&my_sub + ... } or: push @INC, [ \&my_sub, $x, $y, ... ]; sub my_sub { - my ($arrayref, $filename) = @_; - # Retrieve $x, $y, ... - my @parameters = @$arrayref[1..$#$arrayref]; - ... + my ($arrayref, $filename) = @_; + # Retrieve $x, $y, ... + my @parameters = @$arrayref[1..$#$arrayref]; + ... } If the hook is an object, it must provide an INC method that will be @@ -4704,8 +4718,8 @@ into package C<main>.) Here is a typical code layout: package Foo; sub new { ... } sub Foo::INC { - my ($self, $filename) = @_; - ... + my ($self, $filename) = @_; + ... } # In the main program @@ -4728,11 +4742,11 @@ allowed for ranges). All variables and arrays beginning with one of those letters are reset to their pristine state. If the expression is omitted, one-match searches (C<?pattern?>) are reset to match again. Resets only variables or searches in the current package. Always returns -1. Examples: +1. Examples: - reset 'X'; # reset all X variables - reset 'a-z'; # reset lower case variables - reset; # just reset ?one-time? searches + reset 'X'; # reset all X variables + reset 'a-z'; # reset lower case variables + reset; # just reset ?one-time? searches Resetting C<"A-Z"> is not recommended because you'll wipe out your C<@ARGV> and C<@INC> arrays and your C<%ENV> hash. Resets only package @@ -4774,13 +4788,17 @@ Used without arguments in scalar context, reverse() reverses C<$_>. print reverse; # No output, list context print scalar reverse; # Hello, world +Note that reversing an array to itself (as in C<@a = reverse @a>) will +preserve non-existent elements whenever possible, i.e. for non magical +arrays or tied arrays with C<EXISTS> and C<DELETE> methods. + This operator is also handy for inverting a hash, although there are some caveats. If a value is duplicated in the original hash, only one of those can be represented as a key in the inverted hash. Also, this has to unwind one hash and build a whole new one, which may take some time on a large hash, such as from a DBM file. - %by_name = reverse %by_address; # Invert the hash + %by_name = reverse %by_address; # Invert the hash =item rewinddir DIRHANDLE X<rewinddir> @@ -4848,12 +4866,12 @@ evaluated in scalar context. This is seldom what you want. The following single statement: - print uc(scalar(&foo,$bar)),$baz; + print uc(scalar(&foo,$bar)),$baz; is the moral equivalent of these two: - &foo; - print(uc($bar),$baz); + &foo; + print(uc($bar),$baz); See L<perlop> for more details on unary operators and the comma operator. @@ -4896,12 +4914,12 @@ If that doesn't work (some IO implementations are particularly cantankerous), then you may need something more like this: for (;;) { - for ($curpos = tell(FILE); $_ = <FILE>; + for ($curpos = tell(FILE); $_ = <FILE>; $curpos = tell(FILE)) { - # search for some stuff and put it into files - } - sleep($for_a_while); - seek(FILE, $curpos, 0); + # search for some stuff and put it into files + } + sleep($for_a_while); + seek(FILE, $curpos, 0); } =item seekdir DIRHANDLE,POS @@ -4956,12 +4974,12 @@ If you want to select on many filehandles you might wish to write a subroutine: sub fhbits { - my(@fhlist) = split(' ',$_[0]); - my($bits); - for (@fhlist) { - vec($bits,fileno($_),1) = 1; - } - $bits; + my(@fhlist) = split(' ',$_[0]); + my($bits); + for (@fhlist) { + vec($bits,fileno($_),1) = 1; + } + $bits; } $rin = fhbits('STDIN TTY SOCK'); @@ -5314,87 +5332,87 @@ Examples: # sort lexically @articles = sort @files; - + # same thing, but with explicit sort routine @articles = sort {$a cmp $b} @files; - + # now case-insensitively @articles = sort {uc($a) cmp uc($b)} @files; - + # same thing in reversed order @articles = sort {$b cmp $a} @files; - + # sort numerically ascending @articles = sort {$a <=> $b} @files; - + # sort numerically descending @articles = sort {$b <=> $a} @files; - + # this sorts the %age hash by value instead of key # using an in-line function @eldest = sort { $age{$b} <=> $age{$a} } keys %age; - + # sort using explicit subroutine name sub byage { - $age{$a} <=> $age{$b}; # presuming numeric + $age{$a} <=> $age{$b}; # presuming numeric } @sortedclass = sort byage @class; - + sub backwards { $b cmp $a } @harry = qw(dog cat x Cain Abel); @george = qw(gone chased yz Punished Axed); print sort @harry; - # prints AbelCaincatdogx + # prints AbelCaincatdogx print sort backwards @harry; - # prints xdogcatCainAbel + # prints xdogcatCainAbel print sort @george, 'to', @harry; - # prints AbelAxedCainPunishedcatchaseddoggonetoxyz + # prints AbelAxedCainPunishedcatchaseddoggonetoxyz # inefficiently sort by descending numeric compare using # the first integer after the first = sign, or the # whole record case-insensitively otherwise - @new = sort { - ($b =~ /=(\d+)/)[0] <=> ($a =~ /=(\d+)/)[0] - || - uc($a) cmp uc($b) + my @new = sort { + ($b =~ /=(\d+)/)[0] <=> ($a =~ /=(\d+)/)[0] + || + uc($a) cmp uc($b) } @old; # same thing, but much more efficiently; # we'll build auxiliary indices instead # for speed - @nums = @caps = (); + my @nums = @caps = (); for (@old) { - push @nums, /=(\d+)/; - push @caps, uc($_); + push @nums, ( /=(\d+)/ ? $1 : undef ); + push @caps, uc($_); } - @new = @old[ sort { - $nums[$b] <=> $nums[$a] - || - $caps[$a] cmp $caps[$b] - } 0..$#old - ]; + my @new = @old[ sort { + $nums[$b] <=> $nums[$a] + || + $caps[$a] cmp $caps[$b] + } 0..$#old + ]; # same thing, but without any temps @new = map { $_->[0] } sort { $b->[1] <=> $a->[1] - || - $a->[2] cmp $b->[2] - } map { [$_, /=(\d+)/, uc($_)] } @old; + || + $a->[2] cmp $b->[2] + } map { [$_, /=(\d+)/, uc($_)] } @old; # using a prototype allows you to use any comparison subroutine # as a sort subroutine (including other package's subroutines) package other; - sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here - + sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here + package main; @new = sort other::backwards @old; - + # guarantee stability, regardless of algorithm use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; - + # force use of mergesort (not portable outside Perl 5.8) use sort '_mergesort'; # note discouraging _ @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; @@ -5465,22 +5483,22 @@ end of the array. The following equivalences hold (assuming C<< $[ == 0 and $#a >= $i >> ) - push(@a,$x,$y) splice(@a,@a,0,$x,$y) - pop(@a) splice(@a,-1) - shift(@a) splice(@a,0,1) - unshift(@a,$x,$y) splice(@a,0,0,$x,$y) - $a[$i] = $y splice(@a,$i,1,$y) + push(@a,$x,$y) splice(@a,@a,0,$x,$y) + pop(@a) splice(@a,-1) + shift(@a) splice(@a,0,1) + unshift(@a,$x,$y) splice(@a,0,0,$x,$y) + $a[$i] = $y splice(@a,$i,1,$y) Example, assuming array lengths are passed before arrays: - sub aeq { # compare two list values - my(@a) = splice(@_,0,shift); - my(@b) = splice(@_,0,shift); - return 0 unless @a == @b; # same len? - while (@a) { - return 0 if pop(@a) ne pop(@b); - } - return 1; + sub aeq { # compare two list values + my(@a) = splice(@_,0,shift); + my(@b) = splice(@_,0,shift); + return 0 unless @a == @b; # same len? + while (@a) { + return 0 if pop(@a) ne pop(@b); + } + return 1; } if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... } @@ -5596,7 +5614,7 @@ Example: chomp; ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(/:/); - #... + #... } As with regular pattern matching, any capturing parentheses that are not @@ -5635,36 +5653,36 @@ useful. Perl's C<sprintf> permits the following universally-known conversions: - %% a percent sign - %c a character with the given number - %s a string - %d a signed integer, in decimal - %u an unsigned integer, in decimal - %o an unsigned integer, in octal - %x an unsigned integer, in hexadecimal - %e a floating-point number, in scientific notation - %f a floating-point number, in fixed decimal notation - %g a floating-point number, in %e or %f notation + %% a percent sign + %c a character with the given number + %s a string + %d a signed integer, in decimal + %u an unsigned integer, in decimal + %o an unsigned integer, in octal + %x an unsigned integer, in hexadecimal + %e a floating-point number, in scientific notation + %f a floating-point number, in fixed decimal notation + %g a floating-point number, in %e or %f notation In addition, Perl permits the following widely-supported conversions: - %X like %x, but using upper-case letters - %E like %e, but using an upper-case "E" - %G like %g, but with an upper-case "E" (if applicable) - %b an unsigned integer, in binary - %B like %b, but using an upper-case "B" with the # flag - %p a pointer (outputs the Perl value's address in hexadecimal) - %n special: *stores* the number of characters output so far + %X like %x, but using upper-case letters + %E like %e, but using an upper-case "E" + %G like %g, but with an upper-case "E" (if applicable) + %b an unsigned integer, in binary + %B like %b, but using an upper-case "B" with the # flag + %p a pointer (outputs the Perl value's address in hexadecimal) + %n special: *stores* the number of characters output so far into the next variable in the parameter list Finally, for backward (and we do mean "backward") compatibility, Perl permits these unnecessary but widely-supported conversions: - %i a synonym for %d - %D a synonym for %ld - %U a synonym for %lu - %O a synonym for %lo - %F a synonym for %f + %i a synonym for %d + %D a synonym for %ld + %U a synonym for %lu + %O a synonym for %lo + %F a synonym for %f Note that the number of exponent digits in the scientific notation produced by C<%e>, C<%E>, C<%g> and C<%G> for numbers with the modulus of the @@ -5856,9 +5874,9 @@ installation. (This requires that either the platform natively supports quads or Perl was specifically compiled to support quads.) You can find out whether your Perl supports quads via L<Config>: - use Config; - ($Config{use64bitint} eq 'define' || $Config{longsize} >= 8) && - print "quads\n"; + use Config; + ($Config{use64bitint} eq 'define' || $Config{longsize} >= 8) && + print "quads\n"; For floating point conversions (C<e f g E F G>), numbers are usually assumed to be the default floating point size on your platform (double or long double), @@ -5866,8 +5884,8 @@ but you can force 'long double' with C<q>, C<L>, or C<ll> if your platform supports them. You can find out whether your Perl supports long doubles via L<Config>: - use Config; - $Config{d_longdbl} eq 'define' && print "long doubles\n"; + use Config; + $Config{d_longdbl} eq 'define' && print "long doubles\n"; You can find out whether Perl considers 'long double' to be the default floating point size to use on your platform via L<Config>: @@ -5913,10 +5931,10 @@ value to format. Here are some more examples - beware that when using an explicit index, the C<$> may need to be escaped: - printf "%2\$d %d\n", 12, 34; # will print "34 12\n" - printf "%2\$d %d %d\n", 12, 34; # will print "34 12 34\n" - printf "%3\$d %d %d\n", 12, 34, 56; # will print "56 12 34\n" - printf "%2\$*3\$d %d\n", 12, 34, 3; # will print " 34 12\n" + printf "%2\$d %d\n", 12, 34; # will print "34 12\n" + printf "%2\$d %d %d\n", 12, 34; # will print "34 12 34\n" + printf "%3\$d %d %d\n", 12, 34, 56; # will print "56 12 34\n" + printf "%2\$*3\$d %d\n", 12, 34, 3; # will print " 34 12\n" =back @@ -6045,7 +6063,7 @@ stat is done, but the current contents of the stat structure from the last C<stat>, C<lstat>, or filetest are returned. Example: if (-x $file && (($d) = stat(_)) && $d < 0) { - print "$file is executable NFS file\n"; + print "$file is executable NFS file\n"; } (This works on machines only for which the device number is negative @@ -6067,8 +6085,8 @@ The L<File::stat> module provides a convenient, by-name access mechanism: use File::stat; $sb = stat($filename); printf "File is %s, size is %s, perm %04o, mtime %s\n", - $filename, $sb->size, $sb->mode & 07777, - scalar localtime $sb->mtime; + $filename, $sb->size, $sb->mode & 07777, + scalar localtime $sb->mtime; You can import symbolic mode constants (C<S_IF*>) and functions (C<S_IS*>) from the Fcntl module: @@ -6110,11 +6128,11 @@ The commonly available C<S_IF*> constants are and the C<S_IF*> functions are - S_IMODE($mode) the part of $mode containing the permission bits - and the setuid/setgid/sticky bits + S_IMODE($mode) the part of $mode containing the permission bits + and the setuid/setgid/sticky bits - S_IFMT($mode) the part of $mode containing the file type - which can be bit-anded with e.g. S_IFREG + S_IFMT($mode) the part of $mode containing the file type + which can be bit-anded with e.g. S_IFREG or with the following functions # The operators -f, -d, -l, -b, -c, -p, and -S. @@ -6174,12 +6192,12 @@ For example, here is a loop that inserts index producing entries before any line containing a certain pattern: while (<>) { - study; - print ".IX foo\n" if /\bfoo\b/; - print ".IX bar\n" if /\bbar\b/; - print ".IX blurfl\n" if /\bblurfl\b/; - # ... - print; + study; + print ".IX foo\n" if /\bfoo\b/; + print ".IX bar\n" if /\bbar\b/; + print ".IX blurfl\n" if /\bblurfl\b/; + # ... + print; } In searching for C</\bfoo\b/>, only those locations in C<$_> that contain C<f> @@ -6198,15 +6216,15 @@ out the names of those files that contain a match: $search = 'while (<>) { study;'; foreach $word (@words) { - $search .= "++\$seen{\$ARGV} if /\\b$word\\b/;\n"; + $search .= "++\$seen{\$ARGV} if /\\b$word\\b/;\n"; } $search .= "}"; @ARGV = @files; undef $/; - eval $search; # this screams - $/ = "\n"; # put back to normal input delimiter + eval $search; # this screams + $/ = "\n"; # put back to normal input delimiter foreach $file (sort keys(%seen)) { - print $file, "\n"; + print $file, "\n"; } =item sub NAME BLOCK @@ -6242,11 +6260,11 @@ everything to the end of the string. If LENGTH is negative, leaves that many characters off the end of the string. my $s = "The black cat climbed the green tree"; - my $color = substr $s, 4, 5; # black - my $middle = substr $s, 4, -11; # black cat climbed the - my $end = substr $s, 14; # climbed the green tree - my $tail = substr $s, -4; # tree - my $z = substr $s, -4, 2; # tr + my $color = substr $s, 4, 5; # black + my $middle = substr $s, 4, -11; # black cat climbed the + my $end = substr $s, 14; # climbed the green tree + my $tail = substr $s, -4; # tree + my $z = substr $s, -4, 2; # tr You can use the substr() function as an lvalue, in which case EXPR must itself be an lvalue. If you assign something shorter than LENGTH, @@ -6262,10 +6280,10 @@ substring that is entirely outside the string is a fatal error. Here's an example showing the behavior for boundary cases: my $name = 'fred'; - substr($name, 4) = 'dy'; # $name is now 'freddy' - my $null = substr $name, 6, 2; # returns '' (no warning) - my $oops = substr $name, 7; # returns undef, with warning - substr($name, 7) = 'gap'; # fatal error + substr($name, 4) = 'dy'; # $name is now 'freddy' + my $null = substr $name, 6, 2; # returns '' (no warning) + my $oops = substr $name, 7; # returns undef, with warning + substr($name, 7) = 'gap'; # fatal error An alternative to using substr() as an lvalue is to specify the replacement string as the 4th argument. This allows you to replace @@ -6273,7 +6291,7 @@ parts of the EXPR and return what was there before in one operation, just as you can with splice(). my $s = "The black cat climbed the green tree"; - my $z = substr $s, 14, 7, "jumped from"; # climbed + my $z = substr $s, 14, 7, "jumped from"; # climbed # $s is now "The black cat jumped from the green tree" Note that the lvalue returned by the 3-arg version of substr() acts as @@ -6282,10 +6300,10 @@ of the original string is being modified; for example: $x = '1234'; for (substr($x,1,2)) { - $_ = 'a'; print $x,"\n"; # prints 1a4 - $_ = 'xyz'; print $x,"\n"; # prints 1xyz4 + $_ = 'a'; print $x,"\n"; # prints 1a4 + $_ = 'xyz'; print $x,"\n"; # prints 1xyz4 $x = '56789'; - $_ = 'pq'; print $x,"\n"; # prints 5pq9 + $_ = 'pq'; print $x,"\n"; # prints 5pq9 } Prior to Perl version 5.9.1, the result of using an lvalue multiple times was @@ -6318,7 +6336,7 @@ integer arguments are not literals and have never been interpreted in a numeric context, you may need to add C<0> to them to force them to look like numbers. This emulates the C<syswrite> function (or vice versa): - require 'syscall.ph'; # may need to run h2ph + require 'syscall.ph'; # may need to run h2ph $s = "hi there\n"; syscall(&SYS_write, fileno(STDOUT), $s, length $s); @@ -6455,8 +6473,8 @@ and C<SEEK_END> (start of the file, current position, end of the file) from the Fcntl module. Use of the constants is also more portable than relying on 0, 1, and 2. For example to define a "systell" function: - use Fcntl 'SEEK_CUR'; - sub systell { sysseek($_[0], 0, SEEK_CUR) } + use Fcntl 'SEEK_CUR'; + sub systell { sysseek($_[0], 0, SEEK_CUR) } Returns the new position, or the undefined value on failure. A position of zero is returned as the string C<"0 but true">; thus C<sysseek> returns @@ -6509,20 +6527,20 @@ value. @args = ("command", "arg1", "arg2"); system(@args) == 0 - or die "system @args failed: $?" + or die "system @args failed: $?" If you'd like to manually inspect C<system>'s failure, you can check all possible failure modes by inspecting C<$?> like this: if ($? == -1) { - print "failed to execute: $!\n"; + print "failed to execute: $!\n"; } elsif ($? & 127) { - printf "child died with signal %d, %s coredump\n", - ($? & 127), ($? & 128) ? 'with' : 'without'; + printf "child died with signal %d, %s coredump\n", + ($? & 127), ($? & 128) ? 'with' : 'without'; } else { - printf "child exited with value %d\n", $? >> 8; + printf "child exited with value %d\n", $? >> 8; } Alternatively you might inspect the value of C<${^CHILD_ERROR_NATIVE}> @@ -6615,7 +6633,7 @@ C<each> function to iterate over such. Example: use NDBM_File; tie(%HIST, 'NDBM_File', '/usr/lib/news/history', 1, 0); while (($key,$val) = each %HIST) { - print $key, ' = ', unpack('L',$val), "\n"; + print $key, ' = ', unpack('L',$val), "\n"; } untie(%HIST); @@ -6843,20 +6861,29 @@ X<unlink> X<delete> X<remove> X<rm> X<del> =item unlink -Deletes a list of files. Returns the number of files successfully -deleted. +Deletes a list of files. On success, it returns the number of files +it successfully deleted. On failure, it returns false and sets C<$!> +(errno): - $cnt = unlink 'a', 'b', 'c'; + my $unlinked = unlink 'a', 'b', 'c'; unlink @goners; - unlink <*.bak>; + unlink glob "*.bak"; + +On error, C<unlink> will not tell you which files it could not remove. +If you want to know which files you could not remove, try them one +at a time: + + foreach my $file ( @goners ) { + unlink $file or warn "Could not unlink $file: $!"; + } -Note: C<unlink> will not attempt to delete directories unless you are superuser -and the B<-U> flag is supplied to Perl. Even if these conditions are -met, be warned that unlinking a directory can inflict damage on your -filesystem. Finally, using C<unlink> on directories is not supported on -many operating systems. Use C<rmdir> instead. +Note: C<unlink> will not attempt to delete directories unless you are +superuser and the B<-U> flag is supplied to Perl. Even if these +conditions are met, be warned that unlinking a directory can inflict +damage on your filesystem. Finally, using C<unlink> on directories is +not supported on many operating systems. Use C<rmdir> instead. -If LIST is omitted, uses C<$_>. +If LIST is omitted, C<unlink> uses C<$_>. =item unpack TEMPLATE,EXPR X<unpack> @@ -6878,8 +6905,8 @@ The TEMPLATE has the same format as in the C<pack> function. Here's a subroutine that does substring: sub substr { - my($what,$where,$howmuch) = @_; - unpack("x$where a$howmuch", $what); + my($what,$where,$howmuch) = @_; + unpack("x$where a$howmuch", $what); } and then there's @@ -6897,8 +6924,8 @@ For example, the following computes the same number as the System V sum program: $checksum = do { - local $/; # slurp! - unpack("%32W*",<>) % 65535; + local $/; # slurp! + unpack("%32W*",<>) % 65535; }; The following efficiently counts the number of set bits in a bit vector: @@ -6971,9 +6998,9 @@ avoided, because it leads to misleading error messages under earlier versions of Perl (that is, prior to 5.6.0) that do not support this syntax. The equivalent numeric version should be used instead. - use v5.6.1; # compile time version check - use 5.6.1; # ditto - use 5.006_001; # ditto; preferred for backwards compatibility + use v5.6.1; # compile time version check + use 5.6.1; # ditto + use 5.006_001; # ditto; preferred for backwards compatibility This is often useful if you need to check the current Perl version before C<use>ing library modules that won't work with older versions of Perl. @@ -7115,7 +7142,7 @@ leaving it in.) Note that the values are not copied, which means modifying them will modify the contents of the hash: - for (values %hash) { s/foo/bar/g } # modifies %hash values + for (values %hash) { s/foo/bar/g } # modifies %hash values for (@hash{keys %hash}) { s/foo/bar/g } # same See also C<keys>, C<each>, and C<sort>. @@ -7169,22 +7196,22 @@ The comments show the string after each step. Note that this code works in the same way on big-endian or little-endian machines. my $foo = ''; - vec($foo, 0, 32) = 0x5065726C; # 'Perl' + vec($foo, 0, 32) = 0x5065726C; # 'Perl' # $foo eq "Perl" eq "\x50\x65\x72\x6C", 32 bits - print vec($foo, 0, 8); # prints 80 == 0x50 == ord('P') - - vec($foo, 2, 16) = 0x5065; # 'PerlPe' - vec($foo, 3, 16) = 0x726C; # 'PerlPerl' - vec($foo, 8, 8) = 0x50; # 'PerlPerlP' - vec($foo, 9, 8) = 0x65; # 'PerlPerlPe' - vec($foo, 20, 4) = 2; # 'PerlPerlPe' . "\x02" - vec($foo, 21, 4) = 7; # 'PerlPerlPer' - # 'r' is "\x72" - vec($foo, 45, 2) = 3; # 'PerlPerlPer' . "\x0c" - vec($foo, 93, 1) = 1; # 'PerlPerlPer' . "\x2c" - vec($foo, 94, 1) = 1; # 'PerlPerlPerl' - # 'l' is "\x6c" + print vec($foo, 0, 8); # prints 80 == 0x50 == ord('P') + + vec($foo, 2, 16) = 0x5065; # 'PerlPe' + vec($foo, 3, 16) = 0x726C; # 'PerlPerl' + vec($foo, 8, 8) = 0x50; # 'PerlPerlP' + vec($foo, 9, 8) = 0x65; # 'PerlPerlPe' + vec($foo, 20, 4) = 2; # 'PerlPerlPe' . "\x02" + vec($foo, 21, 4) = 7; # 'PerlPerlPer' + # 'r' is "\x72" + vec($foo, 45, 2) = 3; # 'PerlPerlPer' . "\x0c" + vec($foo, 93, 1) = 1; # 'PerlPerlPer' . "\x2c" + vec($foo, 94, 1) = 1; # 'PerlPerlPerl' + # 'l' is "\x6c" To transform a bit vector into a string or list of 0's and 1's, use these: @@ -7379,7 +7406,7 @@ The status is returned in C<$?> and C<${^CHILD_ERROR_NATIVE}>. If you say use POSIX ":sys_wait_h"; #... do { - $kid = waitpid(-1, WNOHANG); + $kid = waitpid(-1, WNOHANG); } while $kid > 0; then you can do a non-blocking wait for all pending zombie processes. @@ -7401,7 +7428,7 @@ C<eval> is looking for a list value. Returns false if the context is looking for a scalar. Returns the undefined value if the context is looking for no value (void context). - return unless defined wantarray; # don't bother doing more + return unless defined wantarray; # don't bother doing more my @a = complex_calculation(); return wantarray ? @a : "@a"; diff --git a/pod/perlguts.pod b/pod/perlguts.pod index afc69aef0b..124712c266 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -278,7 +278,7 @@ efficient shifting and splicing off the beginning of the array; while C<AvARRAY> points to the first element in the array that is visible from Perl, C<AvALLOC> points to the real start of the C array. These are usually the same, but a C<shift> operation can be carried out by -increasing C<AvARRAY> by one and decreasing C<AvFILL> and C<AvLEN>. +increasing C<AvARRAY> by one and decreasing C<AvFILL> and C<AvMAX>. Again, the location of the real start of the C array only comes into play when freeing the array. See C<av_shift> in F<av.c>. diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 6b96a33cc0..73dec46e07 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -393,17 +393,29 @@ the documentation to the modules in core. =item Configure -The configure process is the way we make Perl portable across the +The Configure process is the way we make Perl portable across the myriad of operating systems it supports. Responsibility for the -configure, build and installation process, as well as the overall -portability of the core code rests with the configure pumpkin - others -help out with individual operating systems. +Configure, build and installation process, as well as the overall +portability of the core code rests with the Configure pumpkin - +others help out with individual operating systems. + +The three files that fall under his/her resposibility are Configure, +config_h.SH, and Porting/Glossary (and a whole bunch of small related +files that are less important here). The Configure pumpkin decides how +patches to these are dealt with. Currently, the Configure pumpkin will +accept patches in most common formats, even directly to these files. +Other committers are allowed to commit to these files under the strict +condition that they will inform the Configure pumpkin, either on IRC +(if he/she happens to be around) or through (personal) e-mail. The files involved are the operating system directories, (F<win32/>, F<os2/>, F<vms/> and so on) the shell scripts which generate F<config.h> and F<Makefile>, as well as the metaconfig files which generate F<Configure>. (metaconfig isn't included in the core distribution.) +See http://perl5.git.perl.org/metaconfig.git/blob/HEAD:/README for a +description of the full process involved. + =item Interpreter And of course, there's the core of the Perl interpreter itself. Let's diff --git a/pod/perlhist.pod b/pod/perlhist.pod index 8f4de2f03a..7ea61af9bd 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -404,6 +404,7 @@ the strings?). 5.10.1 2009-Aug-22 Jesse 5.11.0 2009-Oct-02 5.11.1 2009-Oct-20 + Leon 5.11.2 2009-Nov-20 =head2 SELECTED RELEASE SIZES @@ -854,7 +855,7 @@ Jarkko Hietaniemi <F<jhi@iki.fi>>. Thanks to the collective memory of the Perlfolk. In addition to the Keepers of the Pumpkin also Alan Champion, Mark Dominus, -Andreas König, John Macdonald, Matthias Neeracher, Jeff Okamoto, +Andreas König, John Macdonald, Matthias Neeracher, Jeff Okamoto, Michael Peppler, Randal Schwartz, and Paul D. Smith sent corrections and additions. Abigail added file and patch size data for the 5.6.0 - 5.10 era. diff --git a/pod/perlre.pod b/pod/perlre.pod index df627ff012..42017ddf66 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -518,6 +518,10 @@ backreference only if at least 11 left parentheses have opened before it. And so on. \1 through \9 are always interpreted as backreferences. +If the bracketing group did not match, the associated backreference won't +match either. (This can happen if the bracketing group is optional, or +in a different branch of an alternation.) + X<\g{1}> X<\g{-1}> X<\g{name}> X<relative backreference> X<named backreference> In order to provide a safer and easier way to construct patterns using backreferences, Perl provides the C<\g{N}> notation (starting with perl diff --git a/pod/perlreapi.pod b/pod/perlreapi.pod index 03996fd51e..d1d947b8a7 100644 --- a/pod/perlreapi.pod +++ b/pod/perlreapi.pod @@ -410,7 +410,7 @@ name for identification regardless of whether they implement methods on the object. The package this method returns should also have the internal -C<Regexp> package in its C<@ISA>. C<qr//->isa("Regexp")> should always +C<Regexp> package in its C<@ISA>. C<< qr//->isa("Regexp") >> should always be true regardless of what engine is being used. Example implementation might be: diff --git a/pod/perlrepository.pod b/pod/perlrepository.pod index ee3b856f76..8c8131d263 100644 --- a/pod/perlrepository.pod +++ b/pod/perlrepository.pod @@ -57,7 +57,7 @@ directory. If you are a committer, then you can fetch a copy of the repository that you can push back on with: - git clone ssh://perl5.git.perl.org/gitroot/perl.git perl-ssh + git clone ssh://perl5.git.perl.org/perl.git perl-ssh This clones the repository and makes a local copy in the F<perl-ssh> directory. @@ -72,11 +72,7 @@ F<.git/config> where you will see something like: change that to something like this: [remote "origin"] - url = ssh://perl5.git.perl.org/gitroot/perl.git - -NOTE: there are symlinks set up so that the /gitroot is optional and -since SSH is the default protocol you can actually shorten the "url" to -C<perl5.git.perl.org:/perl.git>. + url = ssh://perl5.git.perl.org/perl.git You can also set up your user name and e-mail address. For example @@ -98,14 +94,28 @@ to push your changes back with the C<camel> remote: The C<fetch> command just updates the C<camel> refs, as the objects themselves should have been fetched when pulling from C<origin>. -The committers have access to 2 servers that serve perl5.git.perl.org. -One is camel.booking.com, which is the 'master' repository. The -perl5.git.perl.org IP address also lives on this machine. The second -one is dromedary.booking.com, which can be used for general testing and -development. Dromedary syncs the git tree from camel every few minutes, -you should not push there. Both machines also have a full CPAN mirror. -To share files with the general public, dromedary serves your -~/public_html/ as http://users.perl5.git.perl.org/~yourlogin/ +=head2 A NOTE ON CAMEL AND DROMEDARY + +The committers have SSH access to the two servers that serve +C<perl5.git.perl.org>. One is C<perl5.git.perl.org> itself (I<camel>), +which is the 'master' repository. The second one is +C<users.perl5.git.perl.org> (I<dromedary>), which can be used for +general testing and development. Dromedary syncs the git tree from +camel every few minutes, you should not push there. Both machines also +have a full CPAN mirror in /srv/CPAN, please use this. To share files +with the general public, dromedary serves your ~/public_html/ as +C<http://users.perl5.git.perl.org/~yourlogin/> + +These hosts have fairly strict firewalls to the outside. Outgoing, only +rsync, ssh and git are allowed. For http and ftp, you can use +http://webproxy:3128 as proxy. Incoming, the firewall tries to detect +attacks and blocks IP addresses with suspicious activity. This +sometimes (but very rarely) has false positives and you might get +blocked. The quickest way to get unblocked is to notify the admins. + +These two boxes are owned, hosted, and operated by booking.com. You can +reach the sysadmins in #p5p on irc.perl.org or via mail to +C<perl5-porters@perl.org> =head1 OVERVIEW OF THE REPOSITORY @@ -327,8 +337,8 @@ Now you should create a patch file for all your local changes: You should now send an email to perl5-porters@perl.org with a description of your changes, and include this patch file as an -attachment. (See the next section for how to configure and use -git to send these emails for you.) +attachment. (See the next section for how to configure and use git to +send these emails for you.) If you want to delete your temporary branch, you may do so with: @@ -341,8 +351,8 @@ If you want to delete your temporary branch, you may do so with: =head2 Using git to send patch emails -In your ~/git/perl repository, set the destination email to the perl5-porters -mailing list. +In your ~/git/perl repository, set the destination email to the +perl5-porters mailing list. $ git config sendemail.to perl5-porters@perl.org @@ -350,17 +360,18 @@ Then you can use git directly to send your patch emails: $ git send-email 0001-Rename-Leon-Brocard-to-Orange-Brocard.patch -You may need to set some configuration variables for your particular email -service provider. For example, to set your global git config to send email via -a gmail account: +You may need to set some configuration variables for your particular +email service provider. For example, to set your global git config to +send email via a gmail account: $ git config --global sendemail.smtpserver smtp.gmail.com $ git config --global sendemail.smtpssl 1 $ git config --global sendemail.smtpuser YOURUSERNAME@gmail.com -With this configuration, you will be prompted for your gmail password when you -run 'git send-email'. You can also configure C<sendemail.smtppass> with your -password if you don't care about having your password in the .gitconfig file. +With this configuration, you will be prompted for your gmail password +when you run 'git send-email'. You can also configure +C<sendemail.smtppass> with your password if you don't care about having +your password in the .gitconfig file. =head2 A note on derived files @@ -679,26 +690,26 @@ And then push back to the repository: =head1 TOPIC BRANCHES AND REWRITING HISTORY Individual committers should create topic branches under -B<yourname>/B<some_descriptive_name>. Other committers should check with -a topic branch's creator before making any change to it. +B<yourname>/B<some_descriptive_name>. Other committers should check +with a topic branch's creator before making any change to it. If you are not the creator of B<yourname>/B<some_descriptive_name>, you might sometimes find that the original author has edited the branch's history. There are lots of good reasons for this. Sometimes, an author -might simply be rebasing the branch onto a newer source point. Sometimes, -an author might have found an error in an early commit which they wanted -to fix before merging the branch to blead. +might simply be rebasing the branch onto a newer source point. +Sometimes, an author might have found an error in an early commit which +they wanted to fix before merging the branch to blead. -Currently the master repository is configured to forbid non-fast-forward -merges. This means that the branches within can not be rebased and -pushed as a single step. +Currently the master repository is configured to forbid +non-fast-forward merges. This means that the branches within can not +be rebased and pushed as a single step. -The only way you will ever be allowed to rebase or modify the history of -a pushed branch is to delete it and push it as a new branch under the same -name. Please think carefully about doing this. It may be better to sequentially -rename your branches so that it is easier for others working with you to -cherry-pick their local changes onto the new version. (XXX: needs -explanation). +The only way you will ever be allowed to rebase or modify the history +of a pushed branch is to delete it and push it as a new branch under +the same name. Please think carefully about doing this. It may be +better to sequentially rename your branches so that it is easier for +others working with you to cherry-pick their local changes onto the new +version. (XXX: needs explanation). If you want to rebase a personal topic branch, you will have to delete your existing topic branch and push as a new version of it. You can do @@ -716,25 +727,27 @@ branch: $ git push origin $user/$topic B<NOTE:> it is forbidden at the repository level to delete any of the -"primary" branches. That is any branch matching C<m!^(blead|maint|perl)!>. -Any attempt to do so will result in git producing an error like this: +"primary" branches. That is any branch matching +C<m!^(blead|maint|perl)!>. Any attempt to do so will result in git +producing an error like this: $ git push origin :blead *** It is forbidden to delete blead/maint branches in this repository error: hooks/update exited with error code 1 error: hook declined to update refs/heads/blead - To ssh://camel.booking.com/perl + To ssh://perl5.git.perl.org/perl ! [remote rejected] blead (hook declined) - error: failed to push some refs to 'ssh://camel.booking.com/perl' + error: failed to push some refs to 'ssh://perl5.git.perl.org/perl' -As a matter of policy we do B<not> edit the history of the blead and maint-* -branches. If a typo (or worse) sneaks into a commit to blead or maint-*, we'll -fix it in another commit. The only types of updates allowed on these -branches are "fast-forward's", where all history is preserved. +As a matter of policy we do B<not> edit the history of the blead and +maint-* branches. If a typo (or worse) sneaks into a commit to blead or +maint-*, we'll fix it in another commit. The only types of updates +allowed on these branches are "fast-forward's", where all history is +preserved. -Annotated tags in the canonical perl.git repository will never be deleted -or modified. Think long and hard about whether you want to push a local -tag to perl.git before doing so. (Pushing unannotated tags is +Annotated tags in the canonical perl.git repository will never be +deleted or modified. Think long and hard about whether you want to push +a local tag to perl.git before doing so. (Pushing unannotated tags is not allowed.) =head1 COMMITTING TO MAINTENANCE VERSIONS @@ -759,9 +772,9 @@ original commit in the new commit message. The perl history contains one mistake which was not caught in the conversion -- a merge was recorded in the history between blead and -maint-5.10 where no merge actually occurred. Due to the nature of -git, this is now impossible to fix in the public repository. You can -remove this mis-merge locally by adding the following line to your +maint-5.10 where no merge actually occurred. Due to the nature of git, +this is now impossible to fix in the public repository. You can remove +this mis-merge locally by adding the following line to your C<.git/info/grafts> file: 296f12bbbbaa06de9be9d09d3dcf8f4528898a49 434946e0cb7a32589ed92d18008aaa1d88515930 diff --git a/pod/perlrun.pod b/pod/perlrun.pod index f89c979c75..b98ab788ac 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -1245,6 +1245,20 @@ see L<perlsec/"Algorithmic Complexity Attacks"> for more information. B<Do not disclose the hash seed> to people who don't need to know it. See also hash_seed() of L<Hash::Util>. +=item PERL_MEM_LOG +X<PERL_MEM_LOG> + +If your perl was configured with C<-Accflags=-DPERL_MEM_LOG>, setting the +environment variable C<PERL_MEMLOG> enables logging debug messages. The +value has the form C<< <number>[m][s][t] >>, where C<number> is the +filedescriptor number you want to write to, and the combination of letters +specifies that you want information about (m)emory and/or (s)v, optionally +with (t)imestamps. For example C<PERL_MEMLOG=1mst> will log all +information to stdout. You can write to other opened filedescriptors too, +in a variety of ways; + + bash$ 3>foo3 PERL_MEM_LOG=3m perl ... + =item PERL_ROOT (specific to the VMS port) X<PERL_ROOT> diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 5e80901b09..4e1bc0a8a7 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -272,6 +272,14 @@ conditional is about to be evaluated again. Thus it can be used to increment a loop variable, even when the loop has been continued via the C<next> statement. +Extension modules can also hook into the Perl parser to define new +kinds of compound statement. These are introduced by a keyword which +the extension recognises, and the syntax following the keyword is +defined entirely by the extension. If you are an implementor, see +L<perlapi/PL_keyword_plugin> for the mechanism. If you are using such +a module, see the module's documentation for details of the syntax that +it defines. + =head2 Loop Control X<loop control> X<loop, control> X<next> X<last> X<redo> X<continue> @@ -671,7 +679,7 @@ string occurs in an array: } print "\@array contains $count copies of 'foo'\n"; -On exit from the C<when> block, there is an implicit C<next>. +At the end of all C<when> blocks, there is an implicit C<next>. You can override that with an explicit C<last> if you're only interested in the first match. diff --git a/pod/perlthrtut.pod b/pod/perlthrtut.pod index 55a4cd56f9..00d5e57dcc 100644 --- a/pod/perlthrtut.pod +++ b/pod/perlthrtut.pod @@ -1093,7 +1093,7 @@ L<http://lists.cpan.org/showlist.cgi?name=iThreads> =head1 Bibliography -Here's a short bibliography courtesy of Jürgen Christoffel: +Here's a short bibliography courtesy of Jürgen Christoffel: =head2 Introductory Texts @@ -1150,7 +1150,7 @@ L<http://www.perl.com/pub/a/2002/06/11/threads.html> =head1 Acknowledgements Thanks (in no particular order) to Chaim Frenkel, Steve Fink, Gurusamy -Sarathy, Ilya Zakharevich, Benjamin Sugars, Jürgen Christoffel, Joshua +Sarathy, Ilya Zakharevich, Benjamin Sugars, Jürgen Christoffel, Joshua Pritikin, and Alan Burlison, for their help in reality-checking and polishing this article. Big thanks to Tom Christiansen for his rewrite of the prime number generator. @@ -1161,7 +1161,7 @@ Dan Sugalski E<lt>dan@sidhe.org<gt> Slightly modified by Arthur Bergman to fit the new thread model/module. -Reworked slightly by Jörg Walter E<lt>jwalt@cpan.org<gt> to be more concise +Reworked slightly by Jˆrg Walter E<lt>jwalt@cpan.org<gt> to be more concise about thread-safety of Perl code. Rearranged slightly by Elizabeth Mattijsen E<lt>liz@dijkmat.nl<gt> to put diff --git a/pod/perltodo.pod b/pod/perltodo.pod index b48782c8cd..6362b0e686 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -194,6 +194,11 @@ The F<installman> script is slow. All it is doing text processing, which we're told is something Perl is good at. So it would be nice to know what it is doing that is taking so much CPU, and where possible address it. +=head2 enable lexical enabling/disabling of inidvidual warnings + +Currently, warnings can only be enabled or disabled by category. There +are times when it would be useful to quash a single warning, not a +whole category. =head1 Tasks that need a little sysadmin-type knowledge diff --git a/pod/perlvms.pod b/pod/perlvms.pod index d7ed2bca33..b25a2d7cec 100644 --- a/pod/perlvms.pod +++ b/pod/perlvms.pod @@ -274,7 +274,7 @@ OpenVMS Alpha v7.3-1 and later and all version of OpenVMS I64 support case sensitivity as a process setting (see C<SET PROCESS /CASE_LOOKUP=SENSITIVE>). Perl does not currently suppport case sensitivity on VMS, but it may in the future, so Perl programs should -use the C<File::Spec->case_tolerant> method to determine the state, and +use the C<< File::Spec->case_tolerant >> method to determine the state, and not the C<$^O> variable. =head2 Symbolic Links @@ -63,6 +63,7 @@ PP(pp_padav) { dVAR; dSP; dTARGET; I32 gimme; + assert(SvTYPE(TARG) == SVt_PVAV); if (PL_op->op_private & OPpLVAL_INTRO) if (!(PL_op->op_private & OPpPAD_STATE)) SAVECLEARSV(PAD_SVl(PL_op->op_targ)); @@ -106,6 +107,7 @@ PP(pp_padhv) dVAR; dSP; dTARGET; I32 gimme; + assert(SvTYPE(TARG) == SVt_PVHV); XPUSHs(TARG); if (PL_op->op_private & OPpLVAL_INTRO) if (!(PL_op->op_private & OPpPAD_STATE)) @@ -130,6 +132,9 @@ PP(pp_padhv) /* Translations. */ +const char S_no_symref_sv[] = + "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use"; + PP(pp_rv2gv) { dVAR; dSP; dTOPss; @@ -202,7 +207,7 @@ PP(pp_rv2gv) } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref_sv, sv, (SvCUR(sv)>32 ? "..." : ""), "a symbol"); + DIE(aTHX_ S_no_symref_sv, sv, (SvCUR(sv)>32 ? "..." : ""), "a symbol"); if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) == OPpDONT_INIT_GV) { /* We are the target of a coderef assignment. Return @@ -232,7 +237,7 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what, if (PL_op->op_private & HINT_STRICT_REFS) { if (SvOK(sv)) - Perl_die(aTHX_ PL_no_symref_sv, sv, (SvCUR(sv)>32 ? "..." : ""), what); + Perl_die(aTHX_ S_no_symref_sv, sv, (SvCUR(sv)>32 ? "..." : ""), what); else Perl_die(aTHX_ PL_no_usym, what); } @@ -349,8 +354,7 @@ PP(pp_pos) LvTYPE(TARG) = '.'; if (LvTARG(TARG) != sv) { - if (LvTARG(TARG)) - SvREFCNT_dec(LvTARG(TARG)); + SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc_simple(sv); } PUSHs(TARG); /* no SvSETMAGIC */ @@ -3201,8 +3205,7 @@ PP(pp_substr) sv_insert_flags(sv, pos, rem, repl, repl_len, 0); if (repl_is_utf8) SvUTF8_on(sv); - if (repl_sv_copy) - SvREFCNT_dec(repl_sv_copy); + SvREFCNT_dec(repl_sv_copy); } else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { @@ -3226,8 +3229,7 @@ PP(pp_substr) LvTYPE(TARG) = 'x'; if (LvTARG(TARG) != sv) { - if (LvTARG(TARG)) - SvREFCNT_dec(LvTARG(TARG)); + SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc_simple(sv); } LvTARGOFF(TARG) = upos; @@ -3257,8 +3259,7 @@ PP(pp_vec) } LvTYPE(TARG) = 'v'; if (LvTARG(TARG) != src) { - if (LvTARG(TARG)) - SvREFCNT_dec(LvTARG(TARG)); + SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc_simple(src); } LvTARGOFF(TARG) = offset; @@ -3384,8 +3385,7 @@ PP(pp_index) if (retval > 0 && big_utf8) sv_pos_b2u(big, &retval); } - if (temp) - SvREFCNT_dec(temp); + SvREFCNT_dec(temp); fail: PUSHi(retval + arybase); RETURN; @@ -3530,22 +3530,97 @@ PP(pp_crypt) #endif } +/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So + * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */ + +/* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max + * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF. + * See http://www.unicode.org/unicode/reports/tr16 */ +#define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */ +#define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */ + +/* Below are several macros that generate code */ +/* Generates code to store a unicode codepoint c that is known to occupy + * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */ +#define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \ + STMT_START { \ + *(p) = UTF8_TWO_BYTE_HI(c); \ + *((p)+1) = UTF8_TWO_BYTE_LO(c); \ + } STMT_END + +/* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next + * available byte after the two bytes */ +#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \ + STMT_START { \ + *(p)++ = UTF8_TWO_BYTE_HI(c); \ + *((p)++) = UTF8_TWO_BYTE_LO(c); \ + } STMT_END + +/* Generates code to store the upper case of latin1 character l which is known + * to have its upper case be non-latin1 into the two bytes p and p+1. There + * are only two characters that fit this description, and this macro knows + * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC + * bytes */ +#define STORE_NON_LATIN1_UC(p, l) \ +STMT_START { \ + if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \ + STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \ + } else { /* Must be the following letter */ \ + STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \ + } \ +} STMT_END + +/* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte + * after the character stored */ +#define CAT_NON_LATIN1_UC(p, l) \ +STMT_START { \ + if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \ + CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \ + } else { \ + CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \ + } \ +} STMT_END + +/* Generates code to add the two UTF-8 bytes (probably u) that are the upper + * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l), + * and must require two bytes to store it. Advances p to point to the next + * available position */ +#define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \ +STMT_START { \ + if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \ + CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \ + } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \ + *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \ + } else {/* else is one of the other two special cases */ \ + CAT_NON_LATIN1_UC((p), (l)); \ + } \ +} STMT_END + PP(pp_ucfirst) { + /* Actually is both lcfirst() and ucfirst(). Only the first character + * changes. This means that possibly we can change in-place, ie., just + * take the source and change that one character and store it back, but not + * if read-only etc, or if the length changes */ + dVAR; dSP; SV *source = TOPs; - STRLEN slen; + STRLEN slen; /* slen is the byte length of the whole SV. */ STRLEN need; SV *dest; - bool inplace = TRUE; - bool doing_utf8; + bool inplace; /* ? Convert first char only, in-place */ + bool doing_utf8 = FALSE; /* ? using utf8 */ + bool convert_source_to_utf8 = FALSE; /* ? need to convert */ const int op_type = PL_op->op_type; const U8 *s; U8 *d; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - STRLEN ulen; - STRLEN tculen; + STRLEN ulen; /* ulen is the byte length of the original Unicode character + * stored as UTF-8 at s. */ + STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or + * lowercased) character stored in tmpbuf. May be either + * UTF-8 or not, but in either case is the number of bytes */ SvGETMAGIC(source); if (SvOK(source)) { @@ -3557,25 +3632,187 @@ PP(pp_ucfirst) slen = 0; } - if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) { + /* We may be able to get away with changing only the first character, in + * place, but not if read-only, etc. Later we may discover more reasons to + * not convert in-place. */ + inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source); + + /* First calculate what the changed first character should be. This affects + * whether we can just swap it out, leaving the rest of the string unchanged, + * or even if have to convert the dest to UTF-8 when the source isn't */ + + if (! slen) { /* If empty */ + need = 1; /* still need a trailing NUL */ + } + else if (DO_UTF8(source)) { /* Is the source utf8? */ doing_utf8 = TRUE; - utf8_to_uvchr(s, &ulen); - if (op_type == OP_UCFIRST) { - toTITLE_utf8(s, tmpbuf, &tculen); - } else { - toLOWER_utf8(s, tmpbuf, &tculen); + +/* TODO: This is #ifdefd out because it has hard-coded the standard mappings, + * and doesn't allow for the user to specify their own. When code is added to + * detect if there is a user-defined mapping in force here, and if so to use + * that, then the code below can be compiled. The detection would be a good + * thing anyway, as currently the user-defined mappings only work on utf8 + * strings, and thus depend on the chosen internal storage method, which is a + * bad thing */ +#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS + if (UTF8_IS_INVARIANT(*s)) { + + /* An invariant source character is either ASCII or, in EBCDIC, an + * ASCII equivalent or a caseless C1 control. In both these cases, + * the lower and upper cases of any character are also invariants + * (and title case is the same as upper case). So it is safe to + * use the simple case change macros which avoid the overhead of + * the general functions. Note that if perl were to be extended to + * do locale handling in UTF-8 strings, this wouldn't be true in, + * for example, Lithuanian or Turkic. */ + *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s); + tculen = ulen = 1; + need = slen + 1; + } + else if (UTF8_IS_DOWNGRADEABLE_START(*s)) { + U8 chr; + + /* Similarly, if the source character isn't invariant but is in the + * latin1 range (or EBCDIC equivalent thereof), we have the case + * changes compiled into perl, and can avoid the overhead of the + * general functions. In this range, the characters are stored as + * two UTF-8 bytes, and it so happens that any changed-case version + * is also two bytes (in both ASCIIish and EBCDIC machines). */ + tculen = ulen = 2; + need = slen + 1; + + /* Convert the two source bytes to a single Unicode code point + * value, change case and save for below */ + chr = UTF8_ACCUMULATE(*s, *(s+1)); + if (op_type == OP_LCFIRST) { /* lower casing is easy */ + U8 lower = toLOWER_LATIN1(chr); + STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower); + } + else { /* ucfirst */ + U8 upper = toUPPER_LATIN1_MOD(chr); + + /* Most of the latin1 range characters are well-behaved. Their + * title and upper cases are the same, and are also in the + * latin1 range. The macro above returns their upper (hence + * title) case, and all that need be done is to save the result + * for below. However, several characters are problematic, and + * have to be handled specially. The MOD in the macro name + * above means that these tricky characters all get mapped to + * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS. + * This mapping saves some tests for the majority of the + * characters */ + + if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { + + /* Not tricky. Just save it. */ + STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper); + } + else if (chr == LATIN_SMALL_LETTER_SHARP_S) { + + /* This one is tricky because it is two characters long, + * though the UTF-8 is still two bytes, so the stored + * length doesn't change */ + *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */ + *(tmpbuf + 1) = 's'; + } + else { + + /* The other two have their title and upper cases the same, + * but are tricky because the changed-case characters + * aren't in the latin1 range. They, however, do fit into + * two UTF-8 bytes */ + STORE_NON_LATIN1_UC(tmpbuf, chr); + } + } } - /* If the two differ, we definately cannot do inplace. */ - inplace = (ulen == tculen); - need = slen + 1 - ulen + tculen; - } else { - doing_utf8 = FALSE; - need = slen + 1; + else { +#endif /* end of dont want to break user-defined casing */ + + /* Here, can't short-cut the general case */ + + utf8_to_uvchr(s, &ulen); + if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen); + else toLOWER_utf8(s, tmpbuf, &tculen); + + /* we can't do in-place if the length changes. */ + if (ulen != tculen) inplace = FALSE; + need = slen + 1 - ulen + tculen; +#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS + } +#endif } + else { /* Non-zero length, non-UTF-8, Need to consider locale and if + * latin1 is treated as caseless. Note that a locale takes + * precedence */ + tculen = 1; /* Most characters will require one byte, but this will + * need to be overridden for the tricky ones */ + need = slen + 1; - if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) { - /* We can convert in place. */ + if (op_type == OP_LCFIRST) { + + /* lower case the first letter: no trickiness for any character */ + *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) : + ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s)); + } + /* is ucfirst() */ + else if (IN_LOCALE_RUNTIME) { + *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales + * have upper and title case different + */ + } + else if (! IN_UNI_8_BIT) { + *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or + * on EBCDIC machines whatever the + * native function does */ + } + else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */ + *tmpbuf = toUPPER_LATIN1_MOD(*s); + + /* tmpbuf now has the correct title case for all latin1 characters + * except for the several ones that have tricky handling. All + * of these are mapped by the MOD to the letter below. */ + if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { + + /* The length is going to change, with all three of these, so + * can't replace just the first character */ + inplace = FALSE; + + /* We use the original to distinguish between these tricky + * cases */ + if (*s == LATIN_SMALL_LETTER_SHARP_S) { + /* Two character title case 'Ss', but can remain non-UTF-8 */ + need = slen + 2; + *tmpbuf = 'S'; + *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */ + tculen = 2; + } + else { + + /* The other two tricky ones have their title case outside + * latin1. It is the same as their upper case. */ + doing_utf8 = TRUE; + STORE_NON_LATIN1_UC(tmpbuf, *s); + /* The UTF-8 and UTF-EBCDIC lengths of both these characters + * and their upper cases is 2. */ + tculen = ulen = 2; + + /* The entire result will have to be in UTF-8. Assume worst + * case sizing in conversion. (all latin1 characters occupy + * at most two bytes in utf8) */ + convert_source_to_utf8 = TRUE; + need = slen * 2 + 1; + } + } /* End of is one of the three special chars */ + } /* End of use Unicode (Latin1) semantics */ + } /* End of changing the case of the first character */ + + /* Here, have the first character's changed case stored in tmpbuf. Ready to + * generate the result */ + if (inplace) { + + /* We can convert in place. This means we change just the first + * character without disturbing the rest; no need to grow */ dest = source; s = d = (U8*)SvPV_force_nomg(source, slen); } else { @@ -3583,53 +3820,83 @@ PP(pp_ucfirst) dest = TARG; + /* Here, we can't convert in place; we earlier calculated how much + * space we will need, so grow to accommodate that */ SvUPGRADE(dest, SVt_PV); d = (U8*)SvGROW(dest, need); (void)SvPOK_only(dest); SETs(dest); - - inplace = FALSE; } if (doing_utf8) { - if(!inplace) { - /* slen is the byte length of the whole SV. - * ulen is the byte length of the original Unicode character - * stored as UTF-8 at s. - * tculen is the byte length of the freshly titlecased (or - * lowercased) Unicode character stored as UTF-8 at tmpbuf. - * We first set the result to be the titlecased (/lowercased) - * character, and then append the rest of the SV data. */ - sv_setpvn(dest, (char*)tmpbuf, tculen); - if (slen > ulen) - sv_catpvn(dest, (char*)(s + ulen), slen - ulen); + if (! inplace) { + if (! convert_source_to_utf8) { + + /* Here both source and dest are in UTF-8, but have to create + * the entire output. We initialize the result to be the + * title/lower cased first character, and then append the rest + * of the string. */ + sv_setpvn(dest, (char*)tmpbuf, tculen); + if (slen > ulen) { + sv_catpvn(dest, (char*)(s + ulen), slen - ulen); + } + } + else { + const U8 *const send = s + slen; + + /* Here the dest needs to be in UTF-8, but the source isn't, + * except we earlier UTF-8'd the first character of the source + * into tmpbuf. First put that into dest, and then append the + * rest of the source, converting it to UTF-8 as we go. */ + + /* Assert tculen is 2 here because the only two characters that + * get to this part of the code have 2-byte UTF-8 equivalents */ + *d++ = *tmpbuf; + *d++ = *(tmpbuf + 1); + s++; /* We have just processed the 1st char */ + + for (; s < send; s++) { + d = uvchr_to_utf8(d, *s); + } + *d = '\0'; + SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); + } SvUTF8_on(dest); } - else { + else { /* in-place UTF-8. Just overwrite the first character */ Copy(tmpbuf, d, tculen, U8); SvCUR_set(dest, need - 1); } } - else { - if (*s) { + else { /* Neither source nor dest are in or need to be UTF-8 */ + if (slen) { if (IN_LOCALE_RUNTIME) { TAINT; SvTAINTED_on(dest); - *d = (op_type == OP_UCFIRST) - ? toUPPER_LC(*s) : toLOWER_LC(*s); } - else - *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s); - } else { - /* See bug #39028 */ + if (inplace) { /* in-place, only need to change the 1st char */ + *d = *tmpbuf; + } + else { /* Not in-place */ + + /* Copy the case-changed character(s) from tmpbuf */ + Copy(tmpbuf, d, tculen, U8); + d += tculen - 1; /* Code below expects d to point to final + * character stored */ + } + } + else { /* empty source */ + /* See bug #39028: Don't taint if empty */ *d = *s; } + /* In a "use bytes" we don't treat the source as UTF-8, but, still want + * the destination to retain that flag */ if (SvUTF8(source)) SvUTF8_on(dest); - if (!inplace) { + if (!inplace) { /* Finish the rest of the string, unchanged */ /* This will copy the trailing NUL */ Copy(s + 1, d + 1, slen, U8); SvCUR_set(dest, need - 1); @@ -3641,7 +3908,7 @@ PP(pp_ucfirst) /* There's so much setup/teardown code common between uc and lc, I wonder if it would be worth merging the two, and just having a switch outside each - of the three tight loops. */ + of the three tight loops. There is less and less commonality though */ PP(pp_uc) { dVAR; @@ -3656,9 +3923,16 @@ PP(pp_uc) SvGETMAGIC(source); if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source) - && SvTEMP(source) && !DO_UTF8(source)) { - /* We can convert in place. */ - + && SvTEMP(source) && !DO_UTF8(source) + && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) { + + /* We can convert in place. The reason we can't if in UNI_8_BIT is to + * make the loop tight, so we overwrite the source with the dest before + * looking at it, and we need to look at the original source + * afterwards. There would also need to be code added to handle + * switching to not in-place in midstream if we run into characters + * that change the length. + */ dest = source; s = d = (U8*)SvPV_force_nomg(source, len); min = len + 1; @@ -3698,48 +3972,209 @@ PP(pp_uc) const U8 *const send = s + len; U8 tmpbuf[UTF8_MAXBYTES+1]; +/* This is ifdefd out because it needs more work and thought. It isn't clear + * that we should do it. These are hard-coded rules from the Unicode standard, + * and may change. 5.2 gives new guidance on the iota subscript, for example, + * which has not been checked against this; and secondly it may be that we are + * passed a subset of the context, via a \U...\E, for example, and its not + * clear what the best approach is to that */ +#ifdef CONTEXT_DEPENDENT_CASING + bool in_iota_subscript = FALSE; +#endif + while (s < send) { - const STRLEN u = UTF8SKIP(s); - STRLEN ulen; - - toUPPER_utf8(s, tmpbuf, &ulen); - if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { - /* If the eventually required minimum size outgrows - * the available space, we need to grow. */ - const UV o = d - (U8*)SvPVX_const(dest); - - /* If someone uppercases one million U+03B0s we SvGROW() one - * million times. Or we could try guessing how much to - allocate without allocating too much. Such is life. */ - SvGROW(dest, min); - d = (U8*)SvPVX(dest) + o; +#ifdef CONTEXT_DEPENDENT_CASING + if (in_iota_subscript && ! is_utf8_mark(s)) { + /* A non-mark. Time to output the iota subscript */ +#define GREEK_CAPITAL_LETTER_IOTA 0x0399 +#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345 + + CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA); + in_iota_subscript = FALSE; + } +#endif + + +/* See comments at the first instance in this file of this ifdef */ +#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS + + /* If the UTF-8 character is invariant, then it is in the range + * known by the standard macro; result is only one byte long */ + if (UTF8_IS_INVARIANT(*s)) { + *d++ = toUPPER(*s); + s++; + } + else if (UTF8_IS_DOWNGRADEABLE_START(*s)) { + + /* Likewise, if it fits in a byte, its case change is in our + * table */ + U8 orig = UTF8_ACCUMULATE(*s, *(s+1)); + U8 upper = toUPPER_LATIN1_MOD(orig); + CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper); + s += 2; + } + else { +#else + { +#endif + + /* Otherwise, need the general UTF-8 case. Get the changed + * case value and copy it to the output buffer */ + + const STRLEN u = UTF8SKIP(s); + STRLEN ulen; + +#ifndef CONTEXT_DEPENDENT_CASING + toUPPER_utf8(s, tmpbuf, &ulen); +#else + const UV uv = toUPPER_utf8(s, tmpbuf, &ulen); + if (uv == GREEK_CAPITAL_LETTER_IOTA && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI) { + in_iota_subscript = TRUE; + } + else { +#endif + if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { + /* If the eventually required minimum size outgrows + * the available space, we need to grow. */ + const UV o = d - (U8*)SvPVX_const(dest); + + /* If someone uppercases one million U+03B0s we + * SvGROW() one million times. Or we could try + * guessing how much to 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; + } + Copy(tmpbuf, d, ulen, U8); + d += ulen; +#ifdef CONTEXT_DEPENDENT_CASING + } +#endif + s += u; } - Copy(tmpbuf, d, ulen, U8); - d += ulen; - s += u; } +#ifdef CONTEXT_DEPENDENT_CASING + if (in_iota_subscript) CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA); +#endif SvUTF8_on(dest); *d = '\0'; SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - } else { + } else { /* Not UTF-8 */ if (len) { const U8 *const send = s + len; + + /* Use locale casing if in locale; regular style if not treating + * latin1 as having case; otherwise the latin1 casing. Do the + * whole thing in a tight loop, for speed, */ if (IN_LOCALE_RUNTIME) { TAINT; SvTAINTED_on(dest); for (; s < send; d++, s++) *d = toUPPER_LC(*s); } - else { - for (; s < send; d++, s++) + else if (! IN_UNI_8_BIT) { + for (; s < send; d++, s++) { *d = toUPPER(*s); + } } - } + else { + for (; s < send; d++, s++) { + *d = toUPPER_LATIN1_MOD(*s); + if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue; + + /* The mainstream case is the tight loop above. To avoid + * extra tests in that, all three characters that require + * special handling are mapped by the MOD to the one tested + * just above. + * Use the source to distinguish between the three cases */ + + if (*s == LATIN_SMALL_LETTER_SHARP_S) { + + /* uc() of this requires 2 characters, but they are + * 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++ = 'S'; *d = 'S'; /* upper case is 'SS' */ + continue; /* Back to the tight loop; still in ASCII */ + } + + /* The other two special handling characters have their + * upper cases outside the latin1 range, hence need to be + * in UTF-8, so the whole result needs to be in UTF-8. So, + * here we are somewhere in the middle of processing a + * non-UTF-8 string, and realize that we will have to convert + * the whole thing to UTF-8. What to do? There are + * several possibilities. The simplest to code is to + * convert what we have so far, set a flag, and continue on + * in the loop. The flag would be tested each time through + * the loop, and if set, the next character would be + * converted to UTF-8 and stored. But, I (khw) didn't want + * to slow down the mainstream case at all for this fairly + * rare case, so I didn't want to add a test that didn't + * absolutely have to be there in the loop, besides the + * possibility that it would get too complicated for + * optimizers to deal with. Another possibility is to just + * give up, convert the source to UTF-8, and restart the + * function that way. Another possibility is to convert + * both what has already been processed and what is yet to + * come separately to UTF-8, then jump into the loop that + * handles UTF-8. But the most efficient time-wise of the + * ones I could think of is what follows, and turned out to + * not require much extra code. */ + + /* Convert what we have so far into UTF-8, telling the + * function that we know it should be converted, and to + * allow extra space for what we haven't processed yet. + * Assume the worst case space requirements for converting + * what we haven't processed so far: that it will require + * two bytes for each remaining source character, plus the + * NUL at the end. This may cause the string pointer to + * move, so re-find it. */ + + len = d - (U8*)SvPVX_const(dest); + SvCUR_set(dest, len); + len = sv_utf8_upgrade_flags_grow(dest, + SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, + (send -s) * 2 + 1); + d = (U8*)SvPVX(dest) + len; + + /* And append the current character's upper case in UTF-8 */ + CAT_NON_LATIN1_UC(d, *s); + + /* Now process the remainder of the source, converting to + * upper and UTF-8. If a resulting byte is invariant in + * UTF-8, output it as-is, otherwise convert to UTF-8 and + * append it to the output. */ + + s++; + for (; s < send; s++) { + U8 upper = toUPPER_LATIN1_MOD(*s); + if UTF8_IS_INVARIANT(upper) { + *d++ = upper; + } + else { + CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper); + } + } + + /* Here have processed the whole source; no need to continue + * with the outer loop. Each character has been converted + * to upper case and converted to UTF-8 */ + + break; + } /* End of processing all latin1-style chars */ + } /* End of processing all chars */ + } /* End of source is not empty */ + if (source != dest) { - *d = '\0'; + *d = '\0'; /* Here d points to 1 after last char, add NUL */ SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); } - } + } /* End of isn't utf8 */ SvSETMAGIC(dest); RETURN; } @@ -3759,8 +4194,9 @@ PP(pp_lc) if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source) && SvTEMP(source) && !DO_UTF8(source)) { - /* We can convert in place. */ + /* We can convert in place, as lowercasing anything in the latin1 range + * (or else DO_UTF8 would have been on) doesn't lengthen it */ dest = source; s = d = (U8*)SvPV_force_nomg(source, len); min = len + 1; @@ -3801,56 +4237,148 @@ PP(pp_lc) U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; while (s < send) { - const STRLEN u = UTF8SKIP(s); - STRLEN ulen; - const UV uv = toLOWER_utf8(s, tmpbuf, &ulen); +/* See comments at the first instance in this file of this ifdef */ +#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS + if (UTF8_IS_INVARIANT(*s)) { -#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */ - if (uv == GREEK_CAPITAL_LETTER_SIGMA) { - NOOP; - /* - * Now if the sigma is NOT followed by - * /$ignorable_sequence$cased_letter/; - * and it IS preceded by /$cased_letter$ignorable_sequence/; - * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]* - * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}] - * then it should be mapped to 0x03C2, - * (GREEK SMALL LETTER FINAL SIGMA), - * instead of staying 0x03A3. - * "should be": in other words, this is not implemented yet. - * See lib/unicore/SpecialCasing.txt. + /* Invariant characters use the standard mappings compiled in. */ + *d++ = toLOWER(*s); + s++; } - if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { - /* If the eventually required minimum size outgrows - * the available space, we need to grow. */ - const UV o = d - (U8*)SvPVX_const(dest); - - /* If someone lowercases one million U+0130s we SvGROW() one - * million times. Or we could try guessing how much to - allocate without allocating too much. Such is life. */ - SvGROW(dest, min); - d = (U8*)SvPVX(dest) + o; + else if (UTF8_IS_DOWNGRADEABLE_START(*s)) { + + /* As do the ones in the Latin1 range */ + U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1))); + CAT_UNI_TO_UTF8_TWO_BYTE(d, lower); + s += 2; } - Copy(tmpbuf, d, ulen, U8); - d += ulen; - s += u; - } + else { +#endif + /* Here, is utf8 not in Latin-1 range, have to go out and get + * the mappings from the tables. */ + + const STRLEN u = UTF8SKIP(s); + STRLEN ulen; + +/* See comments at the first instance in this file of this ifdef */ +#ifndef CONTEXT_DEPENDENT_CASING + toLOWER_utf8(s, tmpbuf, &ulen); +#else + /* Here is context dependent casing, not compiled in currently; + * needs more thought and work */ + + const UV uv = toLOWER_utf8(s, tmpbuf, &ulen); + + /* If the lower case is a small sigma, it may be that we need + * to change it to a final sigma. This happens at the end of + * a word that contains more than just this character, and only + * when we started with a capital sigma. */ + if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA && + s > send - len && /* Makes sure not the first letter */ + utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA + ) { + + /* We use the algorithm in: + * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C + * is a CAPITAL SIGMA): If C is preceded by a sequence + * consisting of a cased letter and a case-ignorable + * sequence, and C is not followed by a sequence consisting + * of a case ignorable sequence and then a cased letter, + * then when lowercasing C, C becomes a final sigma */ + + /* To determine if this is the end of a word, need to peek + * ahead. Look at the next character */ + const U8 *peek = s + u; + + /* Skip any case ignorable characters */ + while (peek < send && is_utf8_case_ignorable(peek)) { + peek += UTF8SKIP(peek); + } + + /* If we reached the end of the string without finding any + * non-case ignorable characters, or if the next such one + * is not-cased, then we have met the conditions for it + * being a final sigma with regards to peek ahead, and so + * must do peek behind for the remaining conditions. (We + * know there is stuff behind to look at since we tested + * above that this isn't the first letter) */ + if (peek >= send || ! is_utf8_cased(peek)) { + peek = utf8_hop(s, -1); + + /* Here are at the beginning of the first character + * before the original upper case sigma. Keep backing + * up, skipping any case ignorable characters */ + while (is_utf8_case_ignorable(peek)) { + peek = utf8_hop(peek, -1); + } + + /* Here peek points to the first byte of the closest + * non-case-ignorable character before the capital + * sigma. If it is cased, then by the Unicode + * algorithm, we should use a small final sigma instead + * of what we have */ + if (is_utf8_cased(peek)) { + STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, + UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA); + } + } + } + else { /* Not a context sensitive mapping */ +#endif /* End of commented out context sensitive */ + if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { + + /* If the eventually required minimum size outgrows + * the available space, we need to grow. */ + const UV o = d - (U8*)SvPVX_const(dest); + + /* If someone lowercases one million U+0130s we + * SvGROW() one million times. Or we could try + * guessing how much to allocate without allocating too + * much. Such is life. 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; + } +#ifdef CONTEXT_DEPENDENT_CASING + } +#endif + /* Copy the newly lowercased letter to the output buffer we're + * building */ + Copy(tmpbuf, d, ulen, U8); + d += ulen; + s += u; +#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS + } +#endif + } /* End of looping through the source string */ SvUTF8_on(dest); *d = '\0'; SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - } else { + } else { /* Not utf8 */ if (len) { const U8 *const send = s + len; + + /* Use locale casing if in locale; regular style if not treating + * latin1 as having case; otherwise the latin1 casing. Do the + * whole thing in a tight loop, for speed, */ if (IN_LOCALE_RUNTIME) { TAINT; SvTAINTED_on(dest); for (; s < send; d++, s++) *d = toLOWER_LC(*s); } - else { - for (; s < send; d++, s++) + else if (! IN_UNI_8_BIT) { + for (; s < send; d++, s++) { *d = toLOWER(*s); + } + } + else { + for (; s < send; d++, s++) { + *d = toLOWER_LATIN1(*s); + } } } if (source != dest) { @@ -4299,7 +4827,7 @@ PP(pp_delete) else { SV *keysv = POPs; HV * const hv = MUTABLE_HV(POPs); - SV *sv; + SV *sv = NULL; if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); else if (SvTYPE(hv) == SVt_PVAV) { @@ -4528,9 +5056,9 @@ PP(pp_splice) *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_SPLICE"); call_method("SPLICE",GIMME_V); - LEAVE; + LEAVE_with_name("call_SPLICE"); SPAGAIN; RETURN; } @@ -4724,9 +5252,9 @@ PP(pp_push) *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_PUSH"); call_method("PUSH",G_SCALAR|G_DISCARD); - LEAVE; + LEAVE_with_name("call_PUSH"); SPAGAIN; } else { @@ -4773,9 +5301,9 @@ PP(pp_unshift) *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_UNSHIFT"); call_method("UNSHIFT",G_SCALAR|G_DISCARD); - LEAVE; + LEAVE_with_name("call_UNSHIFT"); SPAGAIN; } else { @@ -4796,17 +5324,76 @@ PP(pp_unshift) PP(pp_reverse) { dVAR; dSP; dMARK; - SV ** const oldsp = SP; if (GIMME == G_ARRAY) { - MARK++; - while (MARK < SP) { - register SV * const tmp = *MARK; - *MARK++ = *SP; - *SP-- = tmp; + if (PL_op->op_private & OPpREVERSE_INPLACE) { + AV *av; + + /* See pp_sort() */ + assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); + (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ + av = MUTABLE_AV((*SP)); + /* In-place reversing only happens in void context for the array + * assignment. We don't need to push anything on the stack. */ + SP = MARK; + + if (SvMAGICAL(av)) { + I32 i, j; + register SV *tmp = sv_newmortal(); + /* For SvCANEXISTDELETE */ + HV *stash; + const MAGIC *mg; + bool can_preserve = SvCANEXISTDELETE(av); + + for (i = 0, j = av_len(av); i < j; ++i, --j) { + register SV *begin, *end; + + if (can_preserve) { + if (!av_exists(av, i)) { + if (av_exists(av, j)) { + register SV *sv = av_delete(av, j, 0); + begin = *av_fetch(av, i, TRUE); + sv_setsv_mg(begin, sv); + } + continue; + } + else if (!av_exists(av, j)) { + register SV *sv = av_delete(av, i, 0); + end = *av_fetch(av, j, TRUE); + sv_setsv_mg(end, sv); + continue; + } + } + + begin = *av_fetch(av, i, TRUE); + end = *av_fetch(av, j, TRUE); + sv_setsv(tmp, begin); + sv_setsv_mg(begin, end); + sv_setsv_mg(end, tmp); + } + } + else { + SV **begin = AvARRAY(av); + SV **end = begin + AvFILLp(av); + + while (begin < end) { + register SV * const tmp = *begin; + *begin++ = *end; + *end-- = tmp; + } + } + } + else { + SV **oldsp = SP; + MARK++; + while (MARK < SP) { + register SV * const tmp = *MARK; + *MARK++ = *SP; + *SP-- = tmp; + } + /* safe as long as stack cannot get extended in the above */ + SP = oldsp; } - /* safe as long as stack cannot get extended in the above */ - SP = oldsp; } else { register char *up; @@ -5276,9 +5863,9 @@ PP(pp_split) } else { PUTBACK; - ENTER; + ENTER_with_name("call_PUSH"); call_method("PUSH",G_SCALAR|G_DISCARD); - LEAVE; + LEAVE_with_name("call_PUSH"); SPAGAIN; if (gimme == G_ARRAY) { I32 i; @@ -5336,6 +5923,7 @@ PP(unimplemented_op) dVAR; DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op), PL_op->op_type); + return NORMAL; } PP(pp_boolkeys) @@ -86,7 +86,7 @@ Refetch the stack pointer. Used after a callback. See L<perlcall>. #define dTARG SV *targ #define NORMAL PL_op->op_next -#define DIE return Perl_die +#define DIE Perl_die /* =for apidoc Ams||PUTBACK @@ -996,14 +996,14 @@ PP(pp_grepstart) PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; pp_pushmark(); /* push dst */ pp_pushmark(); /* push src */ - ENTER; /* enter outer scope */ + ENTER_with_name("grep"); /* enter outer scope */ SAVETMPS; if (PL_op->op_private & OPpGREP_LEX) SAVESPTR(PAD_SVl(PL_op->op_targ)); else SAVE_DEFSV; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; @@ -1084,13 +1084,13 @@ PP(pp_mapwhile) } } } - LEAVE; /* exit inner scope */ + LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { (void)POPMARK; /* pop top */ - LEAVE; /* exit outer scope */ + LEAVE_with_name("grep"); /* exit outer scope */ (void)POPMARK; /* pop src */ items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ @@ -1113,7 +1113,7 @@ PP(pp_mapwhile) else { SV *src; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); /* set $_ to the new source item */ @@ -1543,7 +1543,7 @@ Perl_qerror(pTHX_ SV *err) ++PL_parser->error_count; } -OP * +void Perl_die_where(pTHX_ SV *msv) { dVAR; @@ -1632,14 +1632,15 @@ Perl_die_where(pTHX_ SV *msv) *msg ? msg : "Unknown error\n"); } assert(CxTYPE(cx) == CXt_EVAL); - return cx->blk_eval.retop; + PL_restartop = cx->blk_eval.retop; + JMPENV_JUMP(3); + /* NOTREACHED */ } } write_to_stderr( msv ? msv : ERRSV ); my_failure_exit(); /* NOTREACHED */ - return 0; } PP(pp_xor) @@ -1857,7 +1858,7 @@ PP(pp_dbstate) /* don't do recursive DB::DB call */ return NORMAL; - ENTER; + ENTER_with_name("sub"); SAVETMPS; SAVEI32(PL_debug); @@ -1872,7 +1873,7 @@ PP(pp_dbstate) (void)(*CvXSUB(cv))(aTHX_ cv); CvDEPTH(cv)--; FREETMPS; - LEAVE; + LEAVE_with_name("sub"); return NORMAL; } else { @@ -1900,7 +1901,7 @@ PP(pp_enteriter) PAD *iterdata; #endif - ENTER; + ENTER_with_name("loop1"); SAVETMPS; if (PL_op->op_targ) { @@ -1929,7 +1930,7 @@ PP(pp_enteriter) if (PL_op->op_private & OPpITER_DEF) cxtype |= CXp_FOR_DEF; - ENTER; + ENTER_with_name("loop2"); PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS @@ -2026,9 +2027,9 @@ PP(pp_enterloop) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("loop1"); SAVETMPS; - ENTER; + ENTER_with_name("loop2"); PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); PUSHLOOP_PLAIN(cx, SP); @@ -2071,8 +2072,8 @@ PP(pp_leaveloop) POPLOOP(cx); /* Stack values are safe: release loop vars ... */ PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; - LEAVE; + LEAVE_with_name("loop2"); + LEAVE_with_name("loop1"); return NORMAL; } @@ -2088,7 +2089,7 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; SV *sv; - OP *retop; + OP *retop = NULL; const I32 cxix = dopoptosub(cxstack_ix); @@ -2210,7 +2211,7 @@ PP(pp_last) I32 pop2 = 0; I32 gimme; I32 optype; - OP *nextop; + OP *nextop = NULL; SV **newsp; PMOP *newpm; SV **mark; @@ -2533,7 +2534,7 @@ PP(pp_goto) PUSHMARK(mark); PUTBACK; (void)(*CvXSUB(cv))(aTHX_ cv); - LEAVE; + LEAVE_with_name("sub"); return retop; } else { @@ -2697,6 +2698,12 @@ PP(pp_goto) DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); } + if (*enterops && enterops[1]) { + I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + if (enterops[i]) + deprecate("\"goto\" to jump into a construct"); + } + /* pop unwanted frames */ if (ix < cxstack_ix) { @@ -2871,7 +2878,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PERL_ARGS_ASSERT_SV_COMPILE_2OP; - ENTER; + ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -2932,7 +2939,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) lex_end(); /* XXX DAPM do this properly one year */ *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); - LEAVE; + LEAVE_with_name("eval"); if (IN_PERL_COMPILETIME) CopHINTS_set(&PL_compiling, PL_hints); #ifdef OP_IN_REGISTER @@ -3070,7 +3077,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) POPEVAL(cx); } lex_end(); - LEAVE; /* pp_entereval knows about this LEAVE. */ + LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ msg = SvPVx_nolen_const(ERRSV); if (optype == OP_REQUIRE) { @@ -3103,14 +3110,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVEFREEOP(PL_eval_root); /* Set the context for this new optree. - * If the last op is an OP_REQUIRE, force scalar context. - * Otherwise, propagate the context from the eval(). */ - if (PL_eval_root->op_type == OP_LEAVEEVAL - && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ - && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type - == OP_REQUIRE) - scalar(PL_eval_root); - else if ((gimme & G_WANT) == G_VOID) + * Propagate the context from the eval(). */ + if ((gimme & G_WANT) == G_VOID) scalarvoid(PL_eval_root); else if ((gimme & G_WANT) == G_ARRAY) list(PL_eval_root); @@ -3276,9 +3277,9 @@ PP(pp_require) vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { SV *const importsv = vnormal(sv); *SvPVX_mutable(importsv) = ':'; - ENTER; + ENTER_with_name("load_feature"); Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); - LEAVE; + LEAVE_with_name("load_feature"); } /* If a version >= 5.11.0 is requested, strictures are on by default! */ if (PL_compcv && @@ -3361,7 +3362,7 @@ PP(pp_require) tryname = SvPVX_const(namesv); tryrsfp = NULL; - ENTER; + ENTER_with_name("call_INC"); SAVETMPS; EXTEND(SP, 2); @@ -3439,7 +3440,7 @@ PP(pp_require) PUTBACK; FREETMPS; - LEAVE; + LEAVE_with_name("call_INC"); if (tryrsfp) { hook_sv = dirsv; @@ -3586,7 +3587,7 @@ PP(pp_require) unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } - ENTER; + ENTER_with_name("eval"); SAVETMPS; lex_start(NULL, tryrsfp, TRUE); @@ -3673,7 +3674,7 @@ PP(pp_entereval) TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); - ENTER; + ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; @@ -3817,7 +3818,7 @@ PP(pp_leaveeval) /* die_where() did LEAVE, or we won't be here */ } else { - LEAVE; + LEAVE_with_name("eval"); if (!(save_flags & OPf_SPECIAL)) { CLEAR_ERRSV(); } @@ -3840,7 +3841,7 @@ Perl_delete_eval_scope(pTHX) POPBLOCK(cx,newpm); POPEVAL(cx); PL_curpm = newpm; - LEAVE; + LEAVE_with_name("eval_scope"); PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); PERL_UNUSED_VAR(optype); @@ -3854,7 +3855,7 @@ Perl_create_eval_scope(pTHX_ U32 flags) PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("eval_scope"); SAVETMPS; PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); @@ -3922,7 +3923,7 @@ PP(pp_leavetry) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - LEAVE; + LEAVE_with_name("eval_scope"); CLEAR_ERRSV(); RETURN; } @@ -3933,7 +3934,7 @@ PP(pp_entergiven) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("given"); SAVETMPS; sv_setsv(PAD_SV(PL_op->op_targ), POPs); @@ -3961,7 +3962,7 @@ PP(pp_leavegiven) PL_curpm = newpm; /* pop $1 et al */ - LEAVE; + LEAVE_with_name("given"); return NORMAL; } @@ -3978,7 +3979,7 @@ S_make_matcher(pTHX_ REGEXP *re) PM_SETRE(matcher, ReREFCNT_inc(re)); SAVEFREEOP((OP *) matcher); - ENTER; SAVETMPS; + ENTER_with_name("matcher"); SAVETMPS; SAVEOP(); return matcher; } @@ -4008,7 +4009,7 @@ S_destroy_matcher(pTHX_ PMOP *matcher) PERL_UNUSED_ARG(matcher); FREETMPS; - LEAVE; + LEAVE_with_name("matcher"); } /* Do a smart match */ @@ -4095,7 +4096,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHYES; while ( (he = hv_iternext(hv)) ) { DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); - ENTER; + ENTER_with_name("smartmatch_hash_key_test"); SAVETMPS; PUSHMARK(SP); PUSHs(hv_iterkeysv(he)); @@ -4107,7 +4108,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else andedresults = SvTRUEx(POPs) && andedresults; FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_hash_key_test"); } if (andedresults) RETPUSHYES; @@ -4126,7 +4127,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) for (i = 0; i <= len; ++i) { SV * const * const svp = av_fetch(av, i, FALSE); DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); - ENTER; + ENTER_with_name("smartmatch_array_elem_test"); SAVETMPS; PUSHMARK(SP); if (svp) @@ -4139,7 +4140,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else andedresults = SvTRUEx(POPs) && andedresults; FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_array_elem_test"); } if (andedresults) RETPUSHYES; @@ -4149,7 +4150,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else { sm_any_sub: DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); - ENTER; + ENTER_with_name("smartmatch_coderef"); SAVETMPS; PUSHMARK(SP); PUSHs(d); @@ -4161,7 +4162,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else if (SvTEMP(TOPs)) SvREFCNT_inc_void(TOPs); FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_coderef"); RETURN; } } @@ -4506,7 +4507,7 @@ PP(pp_enterwhen) if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) return cLOGOP->op_other->op_next; - ENTER; + ENTER_with_name("eval"); SAVETMPS; PUSHBLOCK(cx, CXt_WHEN, SP); @@ -4531,7 +4532,7 @@ PP(pp_leavewhen) PL_curpm = newpm; /* pop $1 et al */ - LEAVE; + LEAVE_with_name("eval"); return NORMAL; } @@ -4848,8 +4849,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) int status = 0; SV *upstream; STRLEN got_len; - const char *got_p = NULL; - const char *prune_from = NULL; + char *got_p = NULL; + char *prune_from = NULL; bool read_from_cache = FALSE; STRLEN umaxlen; @@ -4918,7 +4919,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) dSP; int count; - ENTER; + ENTER_with_name("call_filter_sub"); SAVE_DEFSV; SAVETMPS; EXTEND(SP, 2); @@ -4942,7 +4943,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) PUTBACK; FREETMPS; - LEAVE; + LEAVE_with_name("call_filter_sub"); } if(SvOK(upstream)) { @@ -4952,8 +4953,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) prune_from = got_p + umaxlen; } } else { - const char *const first_nl = - (const char *)memchr(got_p, '\n', got_len); + char *const first_nl = (char *)memchr(got_p, '\n', got_len); if (first_nl && first_nl + 1 < got_p + got_len) { /* There's a second line here... */ prune_from = first_nl + 1; @@ -4979,6 +4979,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SvUTF8_on(cache); } SvCUR_set(upstream, got_len - cached_len); + *prune_from = 0; /* Can't yet be EOF */ if (status == 0) status = 1; @@ -157,7 +157,7 @@ PP(pp_sassign) /* We've been returned a constant rather than a full subroutine, but they expect a subroutine reference to apply. */ if (SvROK(cv)) { - ENTER; + ENTER_with_name("sassign_coderef"); SvREFCNT_inc_void(SvRV(cv)); /* newCONSTSUB takes a reference count on the passed in SV from us. We set the name to NULL, otherwise we get into @@ -167,7 +167,7 @@ PP(pp_sassign) SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL, SvRV(cv)))); SvREFCNT_dec(cv); - LEAVE; + LEAVE_with_name("sassign_coderef"); } else { /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; is that @@ -719,14 +719,14 @@ PP(pp_print) PUSHMARK(MARK - 1); *MARK = SvTIED_obj(MUTABLE_SV(io), mg); PUTBACK; - ENTER; + ENTER_with_name("call_PRINT"); if( PL_op->op_type == OP_SAY ) { /* local $\ = "\n" */ SAVEGENERICSV(PL_ors_sv); PL_ors_sv = newSVpvs("\n"); } call_method("PRINT", G_SCALAR); - LEAVE; + LEAVE_with_name("call_PRINT"); SPAGAIN; MARK = ORIGMARK + 1; *MARK = *SP; @@ -1554,9 +1554,9 @@ Perl_do_readline(pTHX) PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; - ENTER; + ENTER_with_name("call_READLINE"); call_method("READLINE", gimme); - LEAVE; + LEAVE_with_name("call_READLINE"); SPAGAIN; if (gimme == G_SCALAR) { SV* const result = POPs; @@ -1764,7 +1764,7 @@ PP(pp_enter) gimme = G_SCALAR; } - ENTER; + ENTER_with_name("block"); SAVETMPS; PUSHBLOCK(cx, CXt_BLOCK, SP); @@ -1891,7 +1891,7 @@ PP(pp_leave) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - LEAVE; + LEAVE_with_name("block"); RETURN; } @@ -2378,14 +2378,14 @@ PP(pp_grepwhile) if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; ++*PL_markstack_ptr; - LEAVE; /* exit inner scope */ + LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (PL_stack_base + *PL_markstack_ptr > SP) { I32 items; const I32 gimme = GIMME_V; - LEAVE; /* exit outer scope */ + LEAVE_with_name("grep"); /* exit outer scope */ (void)POPMARK; /* pop src */ items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ @@ -2408,7 +2408,7 @@ PP(pp_grepwhile) else { SV *src; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; @@ -2474,7 +2474,7 @@ PP(pp_leavesub) } PUTBACK; - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2535,7 +2535,7 @@ PP(pp_leavesublv) * the refcounts so the caller gets a live guy. Cannot set * TEMP, so sv_2mortal is out of question. */ if (!CvLVALUE(cx->blk_sub.cv)) { - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; @@ -2550,7 +2550,7 @@ PP(pp_leavesublv) * of a tied hash or array */ if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) && !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) { - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; @@ -2566,7 +2566,7 @@ PP(pp_leavesublv) } } else { /* Should not happen? */ - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; @@ -2583,7 +2583,7 @@ PP(pp_leavesublv) && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { /* Might be flattened array after $#array = */ PUTBACK; - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; @@ -2638,7 +2638,7 @@ PP(pp_leavesublv) } PUTBACK; - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2668,7 +2668,7 @@ PP(pp_entersub) cv = sv_2cv(sv, &stash, &gv, 0); } if (!cv) { - ENTER; + ENTER_with_name("sub"); SAVETMPS; goto try_autoload; } @@ -2700,7 +2700,7 @@ PP(pp_entersub) if (!sym) DIE(aTHX_ PL_no_usym, "a subroutine"); if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref, sym, len>32 ? "..." : "", "a subroutine"); + DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : ""); cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv)); break; } @@ -2722,7 +2722,7 @@ PP(pp_entersub) break; } - ENTER; + ENTER_with_name("sub"); SAVETMPS; retry: @@ -2882,7 +2882,7 @@ try_autoload: *(PL_stack_base + markix) = *PL_stack_sp; PL_stack_sp = PL_stack_base + markix; } - LEAVE; + LEAVE_with_name("sub"); return NORMAL; } } @@ -321,10 +321,17 @@ S_mul128(pTHX_ SV *sv, U8 m) # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, i, int, char) # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, i, int, char) # elif PTRSIZE == LONGSIZE -# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long, void) -# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long, void) -# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, long, char) -# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, long, char) +# if LONGSIZE < IVSIZE && IVSIZE == 8 +# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, 64, IV, void) +# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, 64, IV, void) +# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, 64, IV, char) +# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, 64, IV, char) +# else +# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void) +# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void) +# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, IV, char) +# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, IV, char) +# endif # elif PTRSIZE == IVSIZE # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void) # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void) @@ -318,13 +318,13 @@ PP(pp_backtick) NOOP; } else if (gimme == G_SCALAR) { - ENTER; + ENTER_with_name("backtick"); SAVESPTR(PL_rs); PL_rs = &PL_sv_undef; sv_setpvs(TARG, ""); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL) NOOP; - LEAVE; + LEAVE_with_name("backtick"); XPUSHs(TARG); SvTAINTED_on(TARG); } @@ -364,7 +364,7 @@ PP(pp_glob) * without at the same time croaking, for some reason, or if * perl was built with PERL_EXTERNAL_GLOB */ - ENTER; + ENTER_with_name("glob"); #ifndef VMS if (PL_tainting) { @@ -389,7 +389,7 @@ PP(pp_glob) #endif /* !DOSISH */ result = do_readline(); - LEAVE; + LEAVE_with_name("glob"); return result; } @@ -497,6 +497,7 @@ PP(pp_die) tmpsv = newSVpvs_flags("Died", SVs_TEMP); DIE(aTHX_ "%"SVf, SVfARG(tmpsv)); + RETURN; } /* I/O. */ @@ -533,9 +534,9 @@ PP(pp_open) *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_OPEN"); call_method("OPEN", G_SCALAR); - LEAVE; + LEAVE_with_name("call_OPEN"); SPAGAIN; RETURN; } @@ -573,9 +574,9 @@ PP(pp_close) PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; - ENTER; + ENTER_with_name("call_CLOSE"); call_method("CLOSE", G_SCALAR); - LEAVE; + LEAVE_with_name("call_CLOSE"); SPAGAIN; RETURN; } @@ -642,6 +643,7 @@ badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); + return NORMAL; #endif } @@ -663,9 +665,9 @@ PP(pp_fileno) PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; - ENTER; + ENTER_with_name("call_FILENO"); call_method("FILENO", G_SCALAR); - LEAVE; + LEAVE_with_name("call_FILENO"); SPAGAIN; RETURN; } @@ -738,9 +740,9 @@ PP(pp_binmode) if (discp) XPUSHs(discp); PUTBACK; - ENTER; + ENTER_with_name("call_BINMODE"); call_method("BINMODE", G_SCALAR); - LEAVE; + LEAVE_with_name("call_BINMODE"); SPAGAIN; RETURN; } @@ -783,7 +785,7 @@ PP(pp_tie) { dVAR; dSP; dMARK; HV* stash; - GV *gv; + GV *gv = NULL; SV *sv; const I32 markoff = MARK - PL_stack_base; const char *methname; @@ -818,7 +820,7 @@ PP(pp_tie) } items = SP - MARK++; if (sv_isobject(*MARK)) { /* Calls GET magic. */ - ENTER; + ENTER_with_name("call_TIE"); PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,(I32)items); @@ -838,7 +840,7 @@ PP(pp_tie) DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no)); } - ENTER; + ENTER_with_name("call_TIE"); PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,(I32)items); @@ -861,7 +863,7 @@ PP(pp_tie) "Self-ties of arrays and hashes are not supported"); sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0); } - LEAVE; + LEAVE_with_name("call_TIE"); SP = PL_stack_base + markoff; PUSHs(sv); RETURN; @@ -888,9 +890,9 @@ PP(pp_untie) XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg)); mXPUSHi(SvREFCNT(obj) - 1); PUTBACK; - ENTER; + ENTER_with_name("call_UNTIE"); call_sv(MUTABLE_SV(cv), G_VOID); - LEAVE; + LEAVE_with_name("call_UNTIE"); SPAGAIN; } else if (mg && SvREFCNT(obj) > 1) { @@ -931,7 +933,7 @@ PP(pp_dbmopen) dVAR; dSP; dPOPPOPssrl; HV* stash; - GV *gv; + GV *gv = NULL; HV * const hv = MUTABLE_HV(POPs); SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP); @@ -1139,6 +1141,7 @@ PP(pp_sselect) RETURN; #else DIE(aTHX_ "select not implemented"); + return NORMAL; #endif } @@ -1158,8 +1161,7 @@ Perl_setdefout(pTHX_ GV *gv) { dVAR; SvREFCNT_inc_simple_void(gv); - if (PL_defoutgv) - SvREFCNT_dec(PL_defoutgv); + SvREFCNT_dec(PL_defoutgv); PL_defoutgv = gv; } @@ -1269,8 +1271,8 @@ PP(pp_enterwrite) register GV *gv; register IO *io; GV *fgv; - CV *cv; - SV * tmpsv = NULL; + CV *cv = NULL; + SV *tmpsv = NULL; if (MAXARG == 0) gv = PL_defoutgv; @@ -2358,6 +2360,7 @@ PP(pp_flock) RETURN; #else DIE(aTHX_ PL_no_func, "flock()"); + return NORMAL; #endif } @@ -2410,6 +2413,7 @@ PP(pp_socket) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socket"); + return NORMAL; #endif } @@ -2471,6 +2475,7 @@ PP(pp_sockpair) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socketpair"); + return NORMAL; #endif } @@ -2502,6 +2507,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "bind"); + return NORMAL; #endif } @@ -2532,6 +2538,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "connect"); + return NORMAL; #endif } @@ -2558,6 +2565,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); + return NORMAL; #endif } @@ -2637,6 +2645,7 @@ badexit: #else DIE(aTHX_ PL_no_sock_func, "accept"); + return NORMAL; #endif } @@ -2661,6 +2670,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); + return NORMAL; #endif } @@ -2738,6 +2748,7 @@ nuts2: #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -2802,6 +2813,7 @@ nuts2: #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -3556,6 +3568,7 @@ PP(pp_chroot) RETURN; #else DIE(aTHX_ PL_no_func, "chroot"); + return NORMAL; #endif } @@ -3630,6 +3643,7 @@ PP(pp_link) { /* Have neither. */ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; } #endif @@ -3845,6 +3859,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); + return NORMAL; #endif } @@ -3852,6 +3867,7 @@ PP(pp_readdir) { #if !defined(Direntry_t) || !defined(HAS_READDIR) DIE(aTHX_ PL_no_dir_func, "readdir"); + return NORMAL; #else #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); @@ -3930,6 +3946,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); + return NORMAL; #endif } @@ -3955,6 +3972,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); + return NORMAL; #endif } @@ -3978,6 +3996,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); + return NORMAL; #endif } @@ -4010,6 +4029,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); + return NORMAL; #endif } @@ -4056,6 +4076,7 @@ PP(pp_fork) RETURN; # else DIE(aTHX_ PL_no_func, "fork"); + return NORMAL; # endif #endif } @@ -4085,6 +4106,7 @@ PP(pp_wait) RETURN; #else DIE(aTHX_ PL_no_func, "wait"); + return NORMAL; #endif } @@ -4115,6 +4137,7 @@ PP(pp_waitpid) RETURN; #else DIE(aTHX_ PL_no_func, "waitpid"); + return NORMAL; #endif } @@ -4320,6 +4343,7 @@ PP(pp_getppid) RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); + return NORMAL; #endif } @@ -4341,6 +4365,7 @@ PP(pp_getpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "getpgrp()"); + return NORMAL; #endif } @@ -4374,6 +4399,7 @@ PP(pp_setpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "setpgrp()"); + return NORMAL; #endif } @@ -4387,6 +4413,7 @@ PP(pp_getpriority) RETURN; #else DIE(aTHX_ PL_no_func, "getpriority()"); + return NORMAL; #endif } @@ -4402,6 +4429,7 @@ PP(pp_setpriority) RETURN; #else DIE(aTHX_ PL_no_func, "setpriority()"); + return NORMAL; #endif } @@ -4452,6 +4480,7 @@ PP(pp_tms) RETURN; # else DIE(aTHX_ "times not implemented"); + return NORMAL; # endif #endif /* HAS_TIMES */ } @@ -4548,6 +4577,7 @@ PP(pp_alarm) RETURN; #else DIE(aTHX_ PL_no_func, "alarm"); + return NORMAL; #endif } @@ -4617,6 +4647,7 @@ PP(pp_semget) RETURN; #else DIE(aTHX_ "System V IPC is not implemented on this machine"); + return NORMAL; #endif } @@ -4677,7 +4708,7 @@ PP(pp_ghostent) struct hostent *gethostbyname(Netdb_name_t); struct hostent *gethostent(void); #endif - struct hostent *hent; + struct hostent *hent = NULL; unsigned long len; EXTEND(SP, 10); @@ -4752,6 +4783,7 @@ PP(pp_ghostent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "gethostent"); + return NORMAL; #endif } @@ -4825,6 +4857,7 @@ PP(pp_gnetent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getnetent"); + return NORMAL; #endif } @@ -4885,6 +4918,7 @@ PP(pp_gprotoent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getprotoent"); + return NORMAL; #endif } @@ -4960,6 +4994,7 @@ PP(pp_gservent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getservent"); + return NORMAL; #endif } @@ -4971,6 +5006,7 @@ PP(pp_shostent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "sethostent"); + return NORMAL; #endif } @@ -4982,6 +5018,7 @@ PP(pp_snetent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setnetent"); + return NORMAL; #endif } @@ -4993,6 +5030,7 @@ PP(pp_sprotoent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setprotoent"); + return NORMAL; #endif } @@ -5004,6 +5042,7 @@ PP(pp_sservent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setservent"); + return NORMAL; #endif } @@ -5016,6 +5055,7 @@ PP(pp_ehostent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endhostent"); + return NORMAL; #endif } @@ -5028,6 +5068,7 @@ PP(pp_enetent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endnetent"); + return NORMAL; #endif } @@ -5040,6 +5081,7 @@ PP(pp_eprotoent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endprotoent"); + return NORMAL; #endif } @@ -5052,6 +5094,7 @@ PP(pp_eservent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endservent"); + return NORMAL; #endif } @@ -5285,6 +5328,7 @@ PP(pp_gpwent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -5296,6 +5340,7 @@ PP(pp_spwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setpwent"); + return NORMAL; #endif } @@ -5307,6 +5352,7 @@ PP(pp_epwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endpwent"); + return NORMAL; #endif } @@ -5381,6 +5427,7 @@ PP(pp_ggrent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -5392,6 +5439,7 @@ PP(pp_sgrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setgrent"); + return NORMAL; #endif } @@ -5403,6 +5451,7 @@ PP(pp_egrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endgrent"); + return NORMAL; #endif } @@ -5418,6 +5467,7 @@ PP(pp_getlogin) RETURN; #else DIE(aTHX_ PL_no_func, "getlogin"); + return NORMAL; #endif } @@ -5516,6 +5566,7 @@ PP(pp_syscall) RETURN; #else DIE(aTHX_ PL_no_func, "syscall"); + return NORMAL; #endif } @@ -5528,6 +5579,7 @@ PP(pp_syscall) static int fcntl_emulate_flock(int fd, int operation) { + int res; struct flock flock; switch (operation & ~LOCK_NB) { @@ -5547,7 +5599,10 @@ fcntl_emulate_flock(int fd, int operation) flock.l_whence = SEEK_SET; flock.l_start = flock.l_len = (Off_t)0; - return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); + res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); + if (res == -1 && ((errno == EAGAIN) || (errno == EACCES))) + errno = EWOULDBLOCK; + return res; } #endif /* FCNTL_EMULATE_FLOCK */ @@ -522,7 +522,9 @@ PERL_CALLCONV OP* Perl_die(pTHX_ const char* pat, ...) #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) STATIC OP* S_vdie(pTHX_ const char* pat, va_list* args); #endif -PERL_CALLCONV OP* Perl_die_where(pTHX_ SV* msv); +PERL_CALLCONV void Perl_die_where(pTHX_ SV* msv) + __attribute__noreturn__; + PERL_CALLCONV void Perl_dounwind(pTHX_ I32 cxix); /* PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp) __attribute__nonnull__(pTHX_2) @@ -941,6 +943,11 @@ PERL_CALLCONV void Perl_gv_name_set(pTHX_ GV* gv, const char *name, U32 len, U32 #define PERL_ARGS_ASSERT_GV_NAME_SET \ assert(gv); assert(name) +PERL_CALLCONV void Perl_gv_try_downgrade(pTHX_ GV* gv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE \ + assert(gv) + PERL_CALLCONV HV* Perl_gv_stashpv(pTHX_ const char* name, I32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GV_STASHPV \ @@ -1424,10 +1431,46 @@ STATIC OP* S_opt_scalarhv(pTHX_ OP* rep_op) #define PERL_ARGS_ASSERT_OPT_SCALARHV \ assert(rep_op) +STATIC OP* S_is_inplace_av(pTHX_ OP* o, OP* oright) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_IS_INPLACE_AV \ + assert(o) + #endif PERL_CALLCONV void Perl_leave_scope(pTHX_ I32 base); PERL_CALLCONV void Perl_lex_end(pTHX); PERL_CALLCONV void Perl_lex_start(pTHX_ SV* line, PerlIO *rsfp, bool new_filter); +PERL_CALLCONV bool Perl_lex_bufutf8(pTHX); +PERL_CALLCONV char* Perl_lex_grow_linestr(pTHX_ STRLEN len); +PERL_CALLCONV void Perl_lex_stuff_pvn(pTHX_ char* pv, STRLEN len, U32 flags) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_LEX_STUFF_PVN \ + assert(pv) + +PERL_CALLCONV void Perl_lex_stuff_sv(pTHX_ SV* sv, U32 flags) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_LEX_STUFF_SV \ + assert(sv) + +PERL_CALLCONV void Perl_lex_unstuff(pTHX_ char* ptr) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_LEX_UNSTUFF \ + assert(ptr) + +PERL_CALLCONV void Perl_lex_read_to(pTHX_ char* ptr) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_LEX_READ_TO \ + assert(ptr) + +PERL_CALLCONV void Perl_lex_discard_to(pTHX_ char* ptr) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_LEX_DISCARD_TO \ + assert(ptr) + +PERL_CALLCONV bool Perl_lex_next_chunk(pTHX_ U32 flags); +PERL_CALLCONV I32 Perl_lex_peek_unichar(pTHX_ U32 flags); +PERL_CALLCONV I32 Perl_lex_read_unichar(pTHX_ U32 flags); +PERL_CALLCONV void Perl_lex_read_space(pTHX_ U32 flags); PERL_CALLCONV void Perl_op_null(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_NULL \ @@ -2350,12 +2393,12 @@ PERL_CALLCONV void Perl_package_version(pTHX_ OP* v) assert(v) PERL_CALLCONV PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype); -PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ const char *const name) +PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_ALLOCMY \ assert(name) -PERL_CALLCONV PADOFFSET Perl_pad_findmy(pTHX_ const char* name) +PERL_CALLCONV PADOFFSET Perl_pad_findmy(pTHX_ const char* name, STRLEN len, U32 flags) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_FINDMY \ @@ -2375,7 +2418,9 @@ PERL_CALLCONV OP* Perl_oopsHV(pTHX_ OP* o) assert(o) PERL_CALLCONV void Perl_pad_leavemy(pTHX); +#ifdef DEBUGGING PERL_CALLCONV SV* Perl_pad_sv(pTHX_ PADOFFSET po); +#endif PERL_CALLCONV void Perl_pad_free(pTHX_ PADOFFSET po); #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) STATIC void S_pad_reset(pTHX); @@ -4275,7 +4320,7 @@ STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const #endif -PERL_CALLCONV void* Perl_get_arena(pTHX_ const size_t svtype, const U32 misc) +PERL_CALLCONV void* Perl_get_arena(pTHX_ const size_t arenasize, const svtype bodytype) __attribute__malloc__ __attribute__warn_unused_result__; @@ -6094,7 +6139,7 @@ PERL_CALLCONV void Perl_pad_undef(pTHX_ CV* cv) #define PERL_ARGS_ASSERT_PAD_UNDEF \ assert(cv) -PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool clone, bool state) +PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, HV *typestash, HV *ourstash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_ADD_NAME \ assert(name) @@ -6104,12 +6149,13 @@ PERL_CALLCONV PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type) #define PERL_ARGS_ASSERT_PAD_ADD_ANON \ assert(sv) -PERL_CALLCONV void Perl_pad_check_dup(pTHX_ const char* name, bool is_our, const HV* ourstash) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_3); +#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) +STATIC void S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash) + __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PAD_CHECK_DUP \ - assert(name); assert(ourstash) + assert(name) +#endif #ifdef DEBUGGING PERL_CALLCONV void Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) __attribute__nonnull__(pTHX_2); @@ -6150,6 +6196,11 @@ STATIC PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, in #define PERL_ARGS_ASSERT_PAD_FINDLEX \ assert(name); assert(cv); assert(out_name_sv); assert(out_flags) +STATIC PADOFFSET S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, HV *ourstash) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_PAD_ADD_NAME_SV \ + assert(namesv) + # if defined(DEBUGGING) STATIC void S_cv_dump(pTHX_ const CV *cv, const char *title) __attribute__nonnull__(pTHX_1) @@ -6176,11 +6227,13 @@ PERL_CALLCONV void Perl_save_set_svflags(pTHX_ SV *sv, U32 mask, U32 val) #define PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS \ assert(sv) +#ifdef DEBUGGING PERL_CALLCONV void Perl_hv_assert(pTHX_ HV *hv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_ASSERT \ assert(hv) +#endif PERL_CALLCONV SV* Perl_hv_scalar(pTHX_ HV *hv) __attribute__warn_unused_result__ @@ -6696,6 +6749,13 @@ PERL_CALLCONV struct refcounted_he * Perl_store_cop_label(pTHX_ struct refcounte assert(label) +PERL_CALLCONV int Perl_keyword_plugin_standard(pTHX_ char* keyword_ptr, STRLEN keyword_len, OP** op_ptr) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD \ + assert(keyword_ptr); assert(op_ptr) + + END_EXTERN_C /* * ex: set ts=8 sts=4 sw=4 noet: @@ -6790,8 +6790,7 @@ S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp) SVfARG(sv_name) ); } - if (sv_name) - SvREFCNT_dec(sv_name); + SvREFCNT_dec(sv_name); if (!cached) SvREFCNT_dec(sv_str); return len ? NULL : (regnode *)&len; @@ -6869,12 +6868,9 @@ S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp) } else { /* zero length */ ret = reg_node(pRExC_state,NOTHING); } - if (!cached) { + SvREFCNT_dec(sv_name); + if (!cached) SvREFCNT_dec(sv_str); - } - if (sv_name) { - SvREFCNT_dec(sv_name); - } return ret; } @@ -8442,9 +8438,7 @@ parseit: *STRING(ret)= (char)value; STR_LEN(ret)= 1; RExC_emit += STR_SZ(1); - if (listsv) { - SvREFCNT_dec(listsv); - } + SvREFCNT_dec(listsv); return ret; } /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */ @@ -9407,24 +9401,18 @@ Perl_pregfree2(pTHX_ REGEXP *rx) ReREFCNT_dec(r->mother_re); } else { CALLREGFREE_PVT(rx); /* free the private data */ - if (RXp_PAREN_NAMES(r)) - SvREFCNT_dec(RXp_PAREN_NAMES(r)); + SvREFCNT_dec(RXp_PAREN_NAMES(r)); } if (r->substrs) { - if (r->anchored_substr) - SvREFCNT_dec(r->anchored_substr); - if (r->anchored_utf8) - SvREFCNT_dec(r->anchored_utf8); - if (r->float_substr) - SvREFCNT_dec(r->float_substr); - if (r->float_utf8) - SvREFCNT_dec(r->float_utf8); + SvREFCNT_dec(r->anchored_substr); + SvREFCNT_dec(r->anchored_utf8); + SvREFCNT_dec(r->float_substr); + SvREFCNT_dec(r->float_utf8); Safefree(r->substrs); } RX_MATCH_COPY_FREE(rx); #ifdef PERL_OLD_COPY_ON_WRITE - if (r->saved_copy) - SvREFCNT_dec(r->saved_copy); + SvREFCNT_dec(r->saved_copy); #endif Safefree(r->offs); } @@ -961,9 +961,9 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, { /* If flags & SOMETHING - do not do it many times on the same match */ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n")); + /* XXX Does the destruction order has to change with do_utf8? */ SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr); - if (do_utf8 ? prog->check_substr : prog->check_utf8) - SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8); + SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8); prog->check_substr = prog->check_utf8 = NULL; /* disable */ prog->float_substr = prog->float_utf8 = NULL; /* clear */ check = NULL; /* abort */ @@ -91,7 +91,13 @@ Perl_push_scope(pTHX) if (PL_scopestack_ix == PL_scopestack_max) { PL_scopestack_max = GROW(PL_scopestack_max); Renew(PL_scopestack, PL_scopestack_max, I32); +#ifdef DEBUGGING + Renew(PL_scopestack_name, PL_scopestack_max, const char*); +#endif } +#ifdef DEBUGGING + PL_scopestack_name[PL_scopestack_ix] = "unknown"; +#endif PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix; } @@ -747,9 +753,7 @@ Perl_leave_scope(pTHX_ I32 base) case SAVEt_AV: /* array reference */ av = MUTABLE_AV(SSPOPPTR); gv = MUTABLE_GV(SSPOPPTR); - if (GvAV(gv)) { - SvREFCNT_dec(GvAV(gv)); - } + SvREFCNT_dec(GvAV(gv)); GvAV(gv) = av; if (SvMAGICAL(av)) { PL_localizing = 2; @@ -760,9 +764,7 @@ Perl_leave_scope(pTHX_ I32 base) case SAVEt_HV: /* hash reference */ hv = MUTABLE_HV(SSPOPPTR); gv = MUTABLE_GV(SSPOPPTR); - if (GvHV(gv)) { - SvREFCNT_dec(GvHV(gv)); - } + SvREFCNT_dec(GvHV(gv)); GvHV(gv) = hv; if (SvMAGICAL(hv)) { PL_localizing = 2; @@ -100,6 +100,20 @@ Opening bracket on a callback. See C<LEAVE> and L<perlcall>. =for apidoc Ams||LEAVE Closing bracket on a callback. See C<ENTER> and L<perlcall>. +=over + +=item ENTER_with_name(name) + +Same as C<ENTER>, but when debugging is enabled it also associates the +given literal string with the new scope. + +=item LEAVE_with_name(name) + +Same as C<LEAVE>, but when debugging is enabled it first checks that the +scope has the given name. Name must be a literal string. + +=back + =cut */ @@ -117,9 +131,28 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. DEBUG_SCOPE("LEAVE") \ pop_scope(); \ } STMT_END +#define ENTER_with_name(name) \ + STMT_START { \ + push_scope(); \ + if (PL_scopestack_name) \ + PL_scopestack_name[PL_scopestack_ix-1] = name; \ + DEBUG_SCOPE("ENTER \"" name "\"") \ + } STMT_END +#define LEAVE_with_name(name) \ + STMT_START { \ + DEBUG_SCOPE("LEAVE \"" name "\"") \ + if (PL_scopestack_name) { \ + assert(((char*)PL_scopestack_name[PL_scopestack_ix-1] \ + == (char*)name) \ + || strEQ(PL_scopestack_name[PL_scopestack_ix-1], name)); \ + } \ + pop_scope(); \ + } STMT_END #else #define ENTER push_scope() #define LEAVE pop_scope() +#define ENTER_with_name(name) ENTER +#define LEAVE_with_name(name) LEAVE #endif #define LEAVE_SCOPE(old) if (PL_savestack_ix > old) leave_scope(old) @@ -607,7 +607,7 @@ Perl_sv_clean_all(pTHX) struct arena_desc { char *arena; /* the raw storage, allocated aligned */ size_t size; /* its size ~4k typ */ - U32 misc; /* type, and in future other things. */ + svtype utype; /* bodytype stored in arena */ }; struct arena_set; @@ -720,7 +720,7 @@ Perl_sv_free_arenas(pTHX) TBD: export properly for hv.c: S_more_he(). */ void* -Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc) +Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype) { dVAR; struct arena_desc* adesc; @@ -749,7 +749,7 @@ Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc) Newx(adesc->arena, arena_size, char); adesc->size = arena_size; - adesc->misc = misc; + adesc->utype = bodytype; DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", curr, (void*)adesc->arena, (UV)arena_size)); @@ -1431,17 +1431,13 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) if (new_type == SVt_PVIO) { IO * const io = MUTABLE_IO(sv); - GV *iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); + GV *iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); SvOBJECT_on(io); /* Clear the stashcache because a new IO could overrule a package name */ hv_clear(PL_stashcache); - /* unless exists($main::{FileHandle}) and - defined(%main::FileHandle::) */ - if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) - iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); IoPAGE_LEN(sv) = 60; } @@ -1456,14 +1452,14 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) (unsigned long)new_type); } - if (old_type_details->arena) { - /* If there was an old body, then we need to free it. - Note that there is an assumption that all bodies of types that - can be upgraded came from arenas. Only the more complex non- - upgradable types are allowed to be directly malloc()ed. */ + if (old_type > SVt_IV) { /* SVt_IVs are overloaded for PTEs */ #ifdef PURIFY my_safefree(old_body); #else + /* Note that there is an assumption that all bodies of types that + can be upgraded came from arenas. Only the more complex non- + upgradable types are allowed to be directly malloc()ed. */ + assert(old_type_details->arena); del_body((void*)((char*)old_body + old_type_details->offset), &PL_body_roots[old_type]); #endif @@ -3250,7 +3246,9 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, ST return SvCUR(sv); } - if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */ + if (SvCUR(sv) == 0) { + if (extra) SvGROW(sv, extra); + } else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we * had a FLAG in SVs to signal if there are any variant * chars in the PV. Given that there isn't such a flag @@ -11783,6 +11781,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_curcop = NULL; PL_markstack = 0; PL_scopestack = 0; + PL_scopestack_name = 0; PL_savestack = 0; PL_savestack_ix = 0; PL_savestack_max = -1; @@ -11821,6 +11820,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_curcop = NULL; PL_markstack = 0; PL_scopestack = 0; + PL_scopestack_name = 0; PL_savestack = 0; PL_savestack_ix = 0; PL_savestack_max = -1; @@ -12282,6 +12282,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newxz(PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); +#ifdef DEBUGGING + Newxz(PL_scopestack_name, PL_scopestack_max, const char *); + Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); +#endif /* NOTE: si_dup() looks at PL_markstack */ PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); @@ -529,7 +529,7 @@ struct xpvfm { DIR * xiou_dirp; /* for opendir, readdir, etc */ \ void * xiou_any; /* for alignment */ \ } xio_dirpu; \ - IV xio_lines; /* $. */ \ + /* IV xio_lines is now in IVX $. */ \ IV xio_page; /* $% */ \ IV xio_page_len; /* $= */ \ IV xio_lines_left; /* $- */ \ @@ -1071,6 +1071,7 @@ the scalar's value cannot change unless written to. assert(SvTYPE(_svivx) != SVt_PVHV); \ assert(SvTYPE(_svivx) != SVt_PVCV); \ assert(SvTYPE(_svivx) != SVt_PVFM); \ + assert(SvTYPE(_svivx) != SVt_PVIO); \ assert(!isGV_with_GP(_svivx)); \ &(((XPVIV*) MUTABLE_PTR(SvANY(_svivx)))->xiv_iv); \ })) @@ -1081,6 +1082,7 @@ the scalar's value cannot change unless written to. assert(SvTYPE(_svuvx) != SVt_PVHV); \ assert(SvTYPE(_svuvx) != SVt_PVCV); \ assert(SvTYPE(_svuvx) != SVt_PVFM); \ + assert(SvTYPE(_svuvx) != SVt_PVIO); \ assert(!isGV_with_GP(_svuvx)); \ &(((XPVUV*) MUTABLE_PTR(SvANY(_svuvx)))->xuv_uv); \ })) @@ -1315,7 +1317,7 @@ the scalar's value cannot change unless written to. #define IoOFP(sv) ((XPVIO*) SvANY(sv))->xio_ofp #define IoDIRP(sv) ((XPVIO*) SvANY(sv))->xio_dirp #define IoANY(sv) ((XPVIO*) SvANY(sv))->xio_any -#define IoLINES(sv) ((XPVIO*) SvANY(sv))->xio_lines +#define IoLINES(sv) ((XPVIO*) SvANY(sv))->xiv_u.xivu_iv #define IoPAGE(sv) ((XPVIO*) SvANY(sv))->xio_page #define IoPAGE_LEN(sv) ((XPVIO*) SvANY(sv))->xio_page_len #define IoLINES_LEFT(sv)((XPVIO*) SvANY(sv))->xio_lines_left diff --git a/symbian/config.sh b/symbian/config.sh index 9885d4df36..a7eda34952 100644 --- a/symbian/config.sh +++ b/symbian/config.sh @@ -22,6 +22,7 @@ cccdlflags='' ccdlflags='' cf_by='root@localhost' cf_time='Thu Jan 1 00:00:00 GMT 1970' +charbits='8' clocktype='clock_t' cpp_stuff='42' cpplast='' diff --git a/symbian/install.cfg b/symbian/install.cfg index 4b86b8211e..879b3619e7 100644 --- a/symbian/install.cfg +++ b/symbian/install.cfg @@ -114,5 +114,6 @@ ext XSLoader # ext Unicode/Normalize nonconst # ext Win32 USELESS # ext XS/APItest USELESS +# ext XS/APItest/KeywordRPN USELESS # ext XS/Typemap nonconst USELESS diff --git a/t/comp/line_debug.t b/t/comp/line_debug.t new file mode 100644 index 0000000000..175c71a65e --- /dev/null +++ b/t/comp/line_debug.t @@ -0,0 +1,31 @@ +#!./perl + +chdir 't' if -d 't'; + +sub ok { + my($test,$ok) = @_; + print "not " unless $ok; + print "ok $test\n"; +} + +# The auxiliary file contains a bunch of code that systematically exercises +# every place that can call lex_next_chunk() (except for the one that's not +# used by the main Perl parser). +open AUX, "<", "comp/line_debug_0.aux" or die $!; +my @lines = <AUX>; +close AUX; +my $nlines = @lines; + +print "1..", 2+$nlines, "\n"; + +$^P = 0x2; +do "comp/line_debug_0.aux"; + +ok 1, scalar(@{"_<comp/line_debug_0.aux"}) == 1+$nlines; +ok 2, !defined(${"_<comp/line_debug_0.aux"}[0]); + +for(1..$nlines) { + ok 2+$_, ${"_<comp/line_debug_0.aux"}[$_] eq $lines[$_-1]; +} + +1; diff --git a/t/comp/line_debug_0.aux b/t/comp/line_debug_0.aux new file mode 100644 index 0000000000..2d31d747aa --- /dev/null +++ b/t/comp/line_debug_0.aux @@ -0,0 +1,20 @@ +$z = 'line one'; +$z + = + 'multiline statement'; +$z = 'line five'; +$z = ' + multiline + string +'; +$z = 'line ten'; +$z = <<EOS; + multiline + heredoc +EOS +$z = 'line fifteen'; +format Z = + @<<<< multiline format + $z +. +$z = 'line twenty'; diff --git a/t/comp/require.t b/t/comp/require.t index c3f034313a..baf48870a3 100644 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -22,7 +22,7 @@ krunch.pm krunch.pmc whap.pm whap.pmc); my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/; -my $total_tests = 48; +my $total_tests = 49; if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; } print "1..$total_tests\n"; @@ -176,6 +176,7 @@ $foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; @foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i; + eval q{return require bleah}; delete $INC{"bleah.pm"}; ++$::i; $foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; @foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; eval {require bleah}; diff --git a/t/comp/use.t b/t/comp/use.t index fade9fec1a..c9b76d79a4 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -6,7 +6,7 @@ BEGIN { $INC{"feature.pm"} = 1; # so we don't attempt to load feature.pm } -print "1..69\n"; +print "1..73\n"; # Can't require test.pl, as we're testing the use/require mechanism here. @@ -62,6 +62,18 @@ sub isnt ($$;$) { _ok ('isnt', @_); } +eval "use 5"; # implicit semicolon +is ($@, ''); + +eval "use 5;"; +is ($@, ''); + +eval "{use 5}"; # [perl #70884] +is ($@, ''); + +eval "{use 5 }"; # [perl #70884] +is ($@, ''); + # new style version numbers eval q{ use v5.5.630; }; diff --git a/t/io/perlio.t b/t/io/perlio.t index cdc4c72775..0bb23fa9e0 100644 --- a/t/io/perlio.t +++ b/t/io/perlio.t @@ -108,7 +108,7 @@ ok(close($utffh)); SKIP: { eval { require PerlIO::scalar }; unless (find PerlIO::Layer 'scalar') { - skip("PerlIO::scalar not found", 8); + skip("PerlIO::scalar not found", 9); } my $var; ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var'); @@ -142,7 +142,6 @@ SKIP: { ok( open(STDERR,">",\$var), ' open STDERR into in-memory var'); open STDERR, ">&OLDERR" or die "cannot dup OLDERR: $!"; } -} { local $TODO = 'fails well back into 5.8.x'; @@ -168,6 +167,8 @@ close ($perlio); close ($no_perlio); } +} + END { 1 while unlink $txt; diff --git a/t/lib/warnings/9enabled b/t/lib/warnings/9enabled index a6ad931ed7..a535689bad 100644 --- a/t/lib/warnings/9enabled +++ b/t/lib/warnings/9enabled @@ -1227,3 +1227,60 @@ print "ok2\n" if $@ =~ /line $warn_line/; EXPECT ok1 ok2 +######## + +--FILE-- fatal1.pm +package fatal1 ; +no warnings ; +print "ok1\n" if !warnings::fatal_enabled('all') ; +print "ok2\n" if !warnings::fatal_enabled("syntax") ; +1; +--FILE-- +use fatal1 ; +EXPECT +ok1 +ok2 +######## + +--FILE-- fatal2.pm +package fatal2; +no warnings ; +print "ok1\n" if !warnings::fatal_enabled('all') ; +print "ok2\n" if warnings::fatal_enabled("syntax") ; +1; +--FILE-- +use warnings FATAL => 'syntax' ; +use fatal2 ; +EXPECT +ok1 +ok2 +######## + +--FILE-- fatal3.pm +package fatal3 ; +no warnings ; +print "ok1\n" if warnings::fatal_enabled('all') ; +print "ok2\n" if warnings::fatal_enabled("syntax") ; +1; +--FILE-- +use warnings FATAL => 'all' ; +use fatal3 ; +EXPECT +ok1 +ok2 +######## + +--FILE-- fatal4.pm +package fatal4 ; +no warnings ; +print "ok1\n" if !warnings::fatal_enabled('all') ; +print "ok2\n" if warnings::fatal_enabled("void") ; +print "ok3\n" if !warnings::fatal_enabled("syntax") ; +1; +--FILE-- +use warnings FATAL => 'all', NONFATAL => 'syntax' ; +use fatal4 ; +EXPECT +ok1 +ok2 +ok3 diff --git a/t/lib/warnings/pad b/t/lib/warnings/pad index bf5c367fc9..54d72cdef9 100644 --- a/t/lib/warnings/pad +++ b/t/lib/warnings/pad @@ -312,3 +312,18 @@ use strict; use warnings; our $x unless $x; EXPECT +######## +use warnings 'misc'; +our $qunckkk; +our $_; +package clank_est; +our $qunckkk; +our $_; +no warnings 'misc'; +our $ouch; +our $_; +package whack; +our $ouch; +our $_; +EXPECT +"our" variable $_ redeclared at - line 6. diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke index a7ef0f8973..223644236b 100644 --- a/t/lib/warnings/toke +++ b/t/lib/warnings/toke @@ -901,3 +901,62 @@ my $bar = qr/^foo${\}n/; EXPECT Possible unintended interpolation of $\ in regex at - line 3. Possible unintended interpolation of $\ in regex at - line 5. +######## +# toke.c +use feature 'state'; +# This one is fine as an empty attribute list +my $holy_Einstein : = ''; +# This one is deprecated +my $krunch := 4; +our $FWISK_FWISK_FWIZZACH_FWACH_ZACHITTY_ZICH_SHAZZATZ_FWISK := ''; +state $thump := 'Trumpets'; +# Lather rinse repeat in my usual obsessive style +my @holy_perfect_pitch : = (); +my @zok := (); +our @GUKGUK := (); +# state @widget_mark := (); +my %holy_seditives : = (); +my %bang := (); +our %GIGAZING := (); +# state %hex := (); +no warnings 'deprecated'; +my $holy_giveaways : = ''; +my $eee_yow := []; +our $TWOYYOYYOING_THUK_UGH := 1 == 1; +state $octothorn := 'Tinky Winky'; +my @holy_Taj_Mahal : = (); +my @touche := (); +our @PLAK_DAK_THUK_FRIT := (); +# state @hash_mark := (); +my %holy_priceless_collection_of_Etruscan_snoods : = (); +my %wham_eth := (); +our %THWUK := (); +# state %octalthorpe := (); +use warnings; +my $holy_sewer_pipe : = ''; +my $thunk := undef; +our $BLIT := time; +state $crunch := 'Laa Laa'; +my @glurpp := (); +my @holy_harem : = (); +our @FABADAP := (); +# state @square := (); +my %holy_pin_cushions : = (); +my %swoosh := (); +our %RRRRR := (); +# state %scratchmark := (); +EXPECT +Use of := for an empty attribute list is deprecated at - line 6. +Use of := for an empty attribute list is deprecated at - line 7. +Use of := for an empty attribute list is deprecated at - line 8. +Use of := for an empty attribute list is deprecated at - line 11. +Use of := for an empty attribute list is deprecated at - line 12. +Use of := for an empty attribute list is deprecated at - line 15. +Use of := for an empty attribute list is deprecated at - line 16. +Use of := for an empty attribute list is deprecated at - line 33. +Use of := for an empty attribute list is deprecated at - line 34. +Use of := for an empty attribute list is deprecated at - line 35. +Use of := for an empty attribute list is deprecated at - line 36. +Use of := for an empty attribute list is deprecated at - line 38. +Use of := for an empty attribute list is deprecated at - line 41. +Use of := for an empty attribute list is deprecated at - line 42. diff --git a/t/op/flip.t b/t/op/flip.t index 5a4e8d0038..8526db776f 100644 --- a/t/op/flip.t +++ b/t/op/flip.t @@ -1,19 +1,22 @@ #!./perl -chdir 't' if -d 't'; +BEGIN { + require "test.pl"; +} -print "1..15\n"; +plan(11); @a = (1,2,3,4,5,6,7,8,9,10,11,12); - +@b = (); while ($_ = shift(@a)) { - if ($x = /4/../8/) { $z = $x; print "ok ", $x + 0, "\n"; } + if ($x = /4/../8/) { $z = $x; push @b, $x + 0; } $y .= /1/../2/; } +is(join("*", @b), "1*2*3*4*5"); -if ($z eq '5E0') {print "ok 6\n";} else {print "not ok 6\n";} +is($z, '5E0'); -if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} +is($y, '12E0123E0'); @a = ('a','b','c','d','e','f','g'); @@ -26,41 +29,36 @@ while (<of>) { } $x = ($foo =~ y/\n/\n/); -if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";} +is($x, 3); $x = 3.14; -if (($x...$x) eq "1") {print "ok 9\n";} else {print "not ok 9\n";} +ok(($x...$x) eq "1"); { # coredump reported in bug 20001018.008 readline(UNKNOWN); $. = 1; $x = 1..10; - print "ok 10\n"; + ok(1); } } -if (!defined $.) { print "ok 11\n" } else { print "not ok 11 # $.\n" } +ok(!defined $.); use warnings; my $warn=''; $SIG{__WARN__} = sub { $warn .= join '', @_ }; -if (0..2) { print "ok 12\n" } else { print "not ok 12\n" } +ok(scalar(0..2)); -if ($warn =~ /uninitialized/) { print "ok 13\n" } else { print "not ok 13\n" } +like($warn, qr/uninitialized/); $warn = ''; $x = "foo".."bar"; -if ((() = ($warn =~ /isn't numeric/g)) == 2) { - print "ok 14\n" -} -else { - print "not ok 14\n" -} +ok((() = ($warn =~ /isn't numeric/g)) == 2); $warn = ''; $. = 15; -if (15..0) { print "ok 15\n" } else { print "not ok 15\n" } +ok(scalar(15..0)); diff --git a/t/op/goto.t b/t/op/goto.t index c79b424b90..5aaf630bb9 100644 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -10,28 +10,37 @@ BEGIN { use warnings; use strict; -plan tests => 58; +plan tests => 66; our $TODO; +my $deprecated = 0; +local $SIG{__WARN__} = sub { if ($_[0] =~ m/jump into a construct/) { $deprecated++; } else { warn $_[0] } }; + our $foo; while ($?) { $foo = 1; label1: + is($deprecated, 1); + $deprecated = 0; $foo = 2; goto label2; } continue { $foo = 0; goto label4; label3: + is($deprecated, 1); + $deprecated = 0; $foo = 4; goto label4; } +is($deprecated, 0); goto label1; $foo = 3; label2: is($foo, 2, 'escape while loop'); +is($deprecated, 0); goto label3; label4: @@ -60,7 +69,7 @@ sub bar { exit; FINALE: -is(curr_test(), 16, 'FINALE'); +is(curr_test(), 20, 'FINALE'); # does goto LABEL handle block contexts correctly? # note that this scope-hopping differs from last & next, @@ -174,13 +183,18 @@ ok($ok, 'works correctly in a nested eval string'); A: { if ($false) { redo A; B: $ok = 1; redo A; } } goto B unless $count++; } + is($deprecated, 0); a(); ok($ok, '#19061 loop label wiped away by goto'); + is($deprecated, 1); + $deprecated = 0; $ok = 0; my $p; for ($p=1;$p && goto A;$p=0) { A: $ok = 1 } ok($ok, 'weird case of goto and for(;;) loop'); + is($deprecated, 1); + $deprecated = 0; } # bug #9990 - don't prematurely free the CV we're &going to. @@ -250,7 +264,7 @@ exit; bypass: -is(curr_test(), 5, 'eval "goto $x"'); +is(curr_test(), 9, 'eval "goto $x"'); # Test autoloading mechanism. @@ -459,3 +473,4 @@ TODO: { } } +is($deprecated, 0); diff --git a/t/op/lex.t b/t/op/lex.t index 3f00248ae5..0789077b5c 100644 --- a/t/op/lex.t +++ b/t/op/lex.t @@ -1,9 +1,10 @@ -#!perl -w +#!perl use strict; +use warnings; require './test.pl'; -plan(tests => 2); +plan(tests => 4); { no warnings 'deprecated'; @@ -20,3 +21,27 @@ $yow } curr_test(3); + + +{ + my %foo = (aap => "monkey"); + my $foo = ''; + is("@{[$foo{'aap'}]}", 'monkey', 'interpolation of hash lookup with space between lexical variable and subscript'); + is("@{[$foo {'aap'}]}", 'monkey', 'interpolation of hash lookup with space between lexical variable and subscript - test for [perl #70091]'); + +# Original bug report [perl #70091] +# #!perl +# use warnings; +# my %foo; +# my $foo = ''; +# (my $tmp = $foo) =~ s/^/$foo {$0}/e; +# __END__ +# +# This program causes a segfault with 5.10.0 and 5.10.1. +# +# The space between '$foo' and '{' is essential, which is why piping +# it through perl -MO=Deparse "fixes" it. +# + +} + diff --git a/t/op/mydef.t b/t/op/mydef.t index 444bf4ae38..e034c78d3a 100644 --- a/t/op/mydef.t +++ b/t/op/mydef.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -print "1..70\n"; +print "1..72\n"; my $test = 0; sub ok ($@) { @@ -198,3 +198,21 @@ my $file = tempfile(); ::ok( $_ ne 'fqdb', 'unqualified $_ is in main' ); ::ok( q/$_/ ne 'fqdb', 'unqualified, evaled $_ is in main' ); } + +{ + $clank_est::qunckkk = 3; + our $qunckkk; + $qunckkk = 4; + package clank_est; + our $qunckkk; + ::ok($qunckkk == 3, 'regular variables are not forced to main'); +} + +{ + $whack::_ = 3; + our $_; + $_ = 4; + package whack; + our $_; + ::ok($_ == 4, '$_ is "special", and always forced to main'); +} diff --git a/t/op/reverse.t b/t/op/reverse.t index bb7b9b77fe..1ad727ace9 100644 --- a/t/op/reverse.t +++ b/t/op/reverse.t @@ -3,23 +3,76 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } -print "1..4\n"; +plan tests => 21; -print "not " unless reverse("abc") eq "cba"; -print "ok 1\n"; +is(reverse("abc"), "cba"); $_ = "foobar"; -print "not " unless reverse() eq "raboof"; -print "ok 2\n"; +is(reverse(), "raboof"); { my @a = ("foo", "bar"); my @b = reverse @a; - print "not " unless $b[0] eq $a[1] && $b[1] eq $a[0]; - print "ok 3\n"; + is($b[0], $a[1]); + is($b[1], $a[0]); +} + +{ + my @a = (1, 2, 3, 4); + @a = reverse @a; + is("@a", "4 3 2 1"); + + delete $a[1]; + @a = reverse @a; + ok(!exists $a[2]); + is($a[0] . $a[1] . $a[3], '124'); + + @a = (5, 6, 7, 8, 9); + @a = reverse @a; + is("@a", "9 8 7 6 5"); + + delete $a[3]; + @a = reverse @a; + ok(!exists $a[1]); + is($a[0] . $a[2] . $a[3] . $a[4], '5789'); + + delete $a[2]; + @a = reverse @a; + ok(!exists $a[2] && !exists $a[3]); + is($a[0] . $a[1] . $a[4], '985'); +} + +use Tie::Array; + +{ + tie my @a, 'Tie::StdArray'; + + @a = (1, 2, 3, 4); + @a = reverse @a; + is("@a", "4 3 2 1"); + + delete $a[1]; + @a = reverse @a; + ok(!exists $a[2]); + is($a[0] . $a[1] . $a[3], '124'); + + @a = (5, 6, 7, 8, 9); + @a = reverse @a; + is("@a", "9 8 7 6 5"); + + delete $a[3]; + @a = reverse @a; + ok(!exists $a[1]); + is($a[0] . $a[2] . $a[3] . $a[4], '5789'); + + delete $a[2]; + @a = reverse @a; + ok(!exists $a[2] && !exists $a[3]); + is($a[0] . $a[1] . $a[4], '985'); } { @@ -28,6 +81,5 @@ print "ok 2\n"; my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}"; my $b = scalar reverse($a); my $c = scalar reverse($b); - print "not " unless $a eq $c; - print "ok 4\n"; + is($a, $c); } diff --git a/t/op/sort.t b/t/op/sort.t index 8484827b6d..75b9a171b3 100644 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -6,7 +6,7 @@ BEGIN { require 'test.pl'; } use warnings; -plan( tests => 146 ); +plan( tests => 147 ); # these shouldn't hang { @@ -768,6 +768,12 @@ cmp_ok($answer,'eq','good','sort subr called from other package'); cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567'); } +{ + local $TODO = "sort should make sure elements are not freed in the sort block"; + eval { @nomodify_x=(1..8); our @copy = sort { @nomodify_x = (0) } (@nomodify_x, 3); }; + is($@, ""); +} + # Sorting shouldn't increase the refcount of a sub { diff --git a/t/op/state.t b/t/op/state.t index 953cd260c0..611dd45217 100644 --- a/t/op/state.t +++ b/t/op/state.t @@ -222,9 +222,9 @@ again: is $simpson, 'Homer', 'goto 1'; goto again if @simpsons; -goto Elvis; my $vi; { + goto Elvis unless $vi; state $calvin = ++ $vi; Elvis: state $vile = ++ $vi; redo unless defined $calvin; diff --git a/t/op/threads.t b/t/op/threads.t index c8ed34a7a1..7985688e5c 100644 --- a/t/op/threads.t +++ b/t/op/threads.t @@ -16,7 +16,7 @@ BEGIN { exit 0; } - plan(14); + plan(15); } use strict; @@ -191,4 +191,21 @@ undef *a; threads->new(sub {})->join; pass("undefing a typeglob doesn't cause a crash during cloning"); + +TODO: { + no strict 'vars'; # Accessing $TODO from test.pl + local $TODO = 'perl #70748'; + +# Test we don't get: +# panic: del_backref during global destruction. +fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic'); +use threads; +sub foo { return (sub { }); } +my $bar = threads->create(\&foo)->join(); +threads->create(sub { })->join(); +print "ok"; +EOI + +} # TODO + # EOF diff --git a/t/op/unshift.t b/t/op/unshift.t index 30291fbac1..9659ee47a0 100644 --- a/t/op/unshift.t +++ b/t/op/unshift.t @@ -1,12 +1,67 @@ #!./perl -print "1..2\n"; +BEGIN { + require "test.pl"; +} -@a = (1,2,3); -$cnt1 = unshift(@a,0); +plan(18); -if (join(' ',@a) eq '0 1 2 3') {print "ok 1\n";} else {print "not ok 1\n";} -$cnt2 = unshift(@a,3,2,1); -if (join(' ',@a) eq '3 2 1 0 1 2 3') {print "ok 2\n";} else {print "not ok 2\n";} +@array = (1, 2, 3); +{ + no warnings 'syntax'; + $count3 = unshift (@array); +} +is(join(' ',@array), '1 2 3', 'unshift null'); +cmp_ok($count3, '==', 3, 'unshift count == 3'); + +$count3_2 = unshift (@array, ()); +is(join(' ',@array), '1 2 3', 'unshift null empty'); +cmp_ok($count3_2, '==', 3, 'unshift count == 3 again'); + +$count4 = unshift (@array, 0); +is(join(' ',@array), '0 1 2 3', 'unshift singleton list'); +cmp_ok($count4, '==', 4, 'unshift count == 4'); + +$count7 = unshift (@array, 3, 2, 1); +is(join(' ',@array), '3 2 1 0 1 2 3', 'unshift list'); +cmp_ok($count7, '==', 7, 'unshift count == 7'); + +@list = (5, 4); +$count9 = unshift (@array, @list); +is(join(' ',@array), '5 4 3 2 1 0 1 2 3', 'unshift array'); +cmp_ok($count9, '==', 9, 'unshift count == 9'); + +@list = (7); +@list2 = (6); +$count11 = unshift (@array, @list, @list2); +is(join(' ',@array), '7 6 5 4 3 2 1 0 1 2 3', 'unshift arrays'); +cmp_ok($count11, '==', 11, 'unshift count == 11'); + +# ignoring counts +@alpha = ('y', 'z'); + +{ + no warnings 'syntax'; + unshift (@alpha); +} +is(join(' ',@alpha), 'y z', 'void unshift null'); + +unshift (@alpha, ()); +is(join(' ',@alpha), 'y z', 'void unshift null empty'); + +unshift (@alpha, 'x'); +is(join(' ',@alpha), 'x y z', 'void unshift singleton list'); + +unshift (@alpha, 'u', 'v', 'w'); +is(join(' ',@alpha), 'u v w x y z', 'void unshift list'); + +@bet = ('s', 't'); +unshift (@alpha, @bet); +is(join(' ',@alpha), 's t u v w x y z', 'void unshift array'); + +@bet = ('q'); +@gimel = ('r'); +unshift (@alpha, @bet, @gimel); +is(join(' ',@alpha), 'q r s t u v w x y z', 'void unshift arrays'); diff --git a/t/op/while_readdir.t b/t/op/while_readdir.t index 851c6d751a..3964158287 100644 --- a/t/op/while_readdir.t +++ b/t/op/while_readdir.t @@ -77,6 +77,7 @@ rewinddir $dirhandle; { my $works = 0; while(readdir $dirhandle){ + $_ =~ s/\.$// if defined $_ && $^O eq 'VMS'; # may have zero-length extension if( defined $_ && $_ eq '0'){ $works = 1; last; @@ -89,6 +90,7 @@ rewinddir $dirhandle; { my $works = 0; my $sub = sub{ + $_ =~ s/\.$// if defined $_ && $^O eq 'VMS'; # may have zero-length extension if( defined $_ && $_ eq '0' ){ $works = 1; } @@ -101,6 +103,7 @@ rewinddir $dirhandle; { my $works = 0; while( my $dir = readdir $dirhandle ){ + $dir =~ s/\.$// if defined $dir && $^O eq 'VMS'; # may have zero-length extension if( defined $dir && $dir eq '0'){ $works = 1; last; @@ -114,7 +117,10 @@ rewinddir $dirhandle; my $tmp; my $ok; my @list; - defined($tmp)&& !$tmp && ($ok=1) while $tmp = readdir $dirhandle; + while( $tmp = readdir $dirhandle ){ + $tmp =~ s/\.$// if defined $tmp && $^O eq 'VMS'; # may have zero-length extension + last if defined($tmp)&& !$tmp && ($ok=1) + } ok( $ok, '$dir while $dir = readdir; with file named "0"' ); rewinddir $dirhandle; } diff --git a/t/porting/diag.t b/t/porting/diag.t index cdb6dba915..66e5a21afa 100644 --- a/t/porting/diag.t +++ b/t/porting/diag.t @@ -222,6 +222,7 @@ Can't %s %s%s%s Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found) Can't take %s of %f Can't use '%c' after -mname +Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use Can't use \\%c to mean $%c in expression Can't use when() outside a topicalizer \\%c better written as $%c diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t index 9775421cd4..a0eec5858a 100644 --- a/t/re/pat_advanced.t +++ b/t/re/pat_advanced.t @@ -21,7 +21,7 @@ BEGIN { } -plan tests => 1146; # Update this when adding/deleting tests. +plan tests => 1142; # Update this when adding/deleting tests. run_tests() unless caller; @@ -1120,7 +1120,6 @@ sub run_tests { '_'.pack('U', 0x00F1), # _ + n-tilde 'c'.pack('U', 0x0327), # c + cedilla pack('U*', 0x00F1, 0x0327), # n-tilde + cedilla - 'a'.pack('U', 0x00B2), # a + superscript two pack('U', 0x0391), # ALPHA pack('U', 0x0391).'2', # ALPHA + 2 pack('U', 0x0391).'_', # ALPHA + _ @@ -1729,8 +1728,8 @@ sub run_tests { my @isPrint = grep {not /[[:print:]]/ and /\p{IsPrint}/} map {chr} 0 .. 0x1f, 0x7f .. 0x9f; - iseq join ('', @isPrint), "\x09\x0a\x0b\x0c\x0d\x85", - 'IsPrint disagrees with [:print:] on control characters'; + iseq join ('', @isPrint), "", + 'IsPrint agrees with [:print:] on control characters'; my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80 .. 0xff; diff --git a/t/re/re_tests b/t/re/re_tests index 725a75255e..dc0308478e 100644 --- a/t/re/re_tests +++ b/t/re/re_tests @@ -275,7 +275,8 @@ a[-]?c ac y $& ac \g{0} - c - Reference to invalid group 0 \g{-0} - c - Reference to invalid group 0 (a)|\1 a y - - -(a)|\1 x n - - +(a)|\1 x n - Reference to group in different branch +(?:(b)?a)\1 a n - Reference to group that did not match (a)|\2 - c - Reference to nonexistent group (([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b (([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c @@ -1393,3 +1394,5 @@ foo(\h)bar foo\tbar y $1 \t '[\x{100}\xff]'i \x{ff} y $& \x{ff} ((??{ "(?:|)" }))\s C\x20 y - - + +# vim: set noexpandtab diff --git a/t/re/regexp_unicode_prop.t b/t/re/regexp_unicode_prop.t index 8cc09f1ade..ba55b96115 100644 --- a/t/re/regexp_unicode_prop.t +++ b/t/re/regexp_unicode_prop.t @@ -106,7 +106,8 @@ my %SHORT_PROPERTIES = ( 'Ll' => ['m', '\N{CYRILLIC SMALL LETTER A}'], 'Lu' => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'], 'Lo' => ['\N{HIRAGANA LETTER SMALL A}'], - 'Mn' => ['\N{COMBINING GRAVE ACCENT}'], + # is also in other alphabetic + 'Mn' => ['\N{HEBREW POINT RAFE}'], 'Nd' => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'], 'Pc' => ["_"], 'Po' => ["!"], diff --git a/t/re/uniprops.t b/t/re/uniprops.t new file mode 100644 index 0000000000..81d31d12e7 --- /dev/null +++ b/t/re/uniprops.t @@ -0,0 +1,9 @@ +use strict; +use warnings; + +# This is just a wrapper for a generated file. Asssumes being run from 't' +# directory + +do '../lib/unicore/TestProp.pl'; + +0 diff --git a/t/run/switches.t b/t/run/switches.t index 8e076d4595..20cb77297a 100644 --- a/t/run/switches.t +++ b/t/run/switches.t @@ -267,8 +267,10 @@ SWTESTPM # there are definitely known build configs where this test will fail # DG/UX comes to mind. Maybe we should remove these special cases? my $v = sprintf "%vd", $^V; + my $ver = $Config{PERL_VERSION}; + my $rel = $Config{PERL_SUBVERSION}; like( runperl( switches => ['-v'] ), - qr/This is perl, v\Q$v\E(?:[-*\w]+| \([^)]+\))? built for \Q$Config{archname}\E.+Copyright.+Larry Wall.+Artistic License.+GNU General Public License/s, + qr/This is perl 5, version \Q$ver\E, subversion \Q$rel\E \(v\Q$v\E(?:[-*\w]+| \([^)]+\))?\) built for \Q$Config{archname}\E.+Copyright.+Larry Wall.+Artistic License.+GNU General Public License/s, '-v looks okay' ); } @@ -158,7 +158,16 @@ sub display { $y = $y . $backslash_escape{$c}; } else { my $z = chr $c; # Maybe we can get away with a literal... - $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; + if ($z =~ /[[:^print:]]/) { + + # Use octal for characters traditionally expressed as + # such: the low controls + if ($c <= 037) { + $z = sprintf "\\%03o", $c; + } else { + $z = sprintf "\\x{%x}", $c; + } + } $y = $y . $z; } } diff --git a/t/uni/cache.t b/t/uni/cache.t index c3f7634fcd..df12f33ba2 100644 --- a/t/uni/cache.t +++ b/t/uni/cache.t @@ -8,7 +8,8 @@ plan tests => 1; my $count = 0; unshift @INC, sub { - $count++ if $_[1] eq 'unicore/lib/gc_sc/Hira.pl'; + # XXX Kludge requires exact path, which might change + $count++ if $_[1] eq 'unicore/lib/Sc/Hira.pl'; }; my $s = 'foo'; diff --git a/t/uni/class.t b/t/uni/class.t index 4620ca0cc1..3dde5082cb 100644 --- a/t/uni/class.t +++ b/t/uni/class.t @@ -4,7 +4,7 @@ BEGIN { require "test.pl"; } -plan tests => 5092; +plan tests => 10; sub MyUniClass { <<END; @@ -71,164 +71,17 @@ is(($str =~ /(\p{Other::Class}+)/)[0], '@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'); # make sure it finds class in other OTHER package is(($str =~ /(\p{A::B::Intersection}+)/)[0], '@ABCDEFGHIJKLMNO'); -# all of these should look in lib/unicore/bc/AL.pl +# lib/unicore/Bc/AL.pl $str = "\x{070D}\x{070E}\x{070F}\x{0710}\x{0711}"; -is(($str =~ /(\P{BidiClass: ArabicLetter}+)/)[0], "\x{070E}\x{070F}"); -is(($str =~ /(\P{BidiClass: AL}+)/)[0], "\x{070E}\x{070F}"); -is(($str =~ /(\P{BC :ArabicLetter}+)/)[0], "\x{070E}\x{070F}"); -is(($str =~ /(\P{bc=AL}+)/)[0], "\x{070E}\x{070F}"); +is(($str =~ /(\P{BidiClass: ArabicLetter}+)/)[0], "\x{070F}"); +is(($str =~ /(\P{BidiClass: AL}+)/)[0], "\x{070F}"); +is(($str =~ /(\P{BC :ArabicLetter}+)/)[0], "\x{070F}"); +is(($str =~ /(\P{bc=AL}+)/)[0], "\x{070F}"); # make sure InGreek works $str = "[\x{038B}\x{038C}\x{038D}]"; is(($str =~ /(\p{InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); -is(($str =~ /(\p{Script:InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); -is(($str =~ /(\p{Script=InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); -is(($str =~ /(\p{sc:InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); -is(($str =~ /(\p{sc=InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); - -use File::Spec; -my $updir = File::Spec->updir; - -# the %utf8::... hashes are already in existence -# because utf8_pva.pl was run by utf8_heavy.pl - -*utf8::PropertyAlias = *utf8::PropertyAlias; # thwart a warning - -no warnings 'utf8'; # we do not want warnings about surrogates etc - -sub char_range { - my ($h1, $h2) = @_; - - my $str; - - if (ord('A') == 193 && $h1 < 256) { - my $h3 = ($h2 || $h1) + 1; - if ($h3 - $h1 == 1) { - $str = join "", pack 'U*', $h1 .. $h3; # Using pack since chr doesn't generate Unicode chars for value < 256. - } elsif ($h3 - $h1 > 1) { - for (my $i = $h1; $i <= $h3; $i++) { - $str = join "", $str, pack 'U*', $i; - } - } - } else { - $str = join "", map chr, $h1 .. (($h2 || $h1) + 1); - } - - return $str; -} - -# non-General Category and non-Script -while (my ($abbrev, $files) = each %utf8::PVA_abbr_map) { - my $prop_name = $utf8::PropertyAlias{$abbrev}; - next unless $prop_name; - next if $abbrev eq "gc_sc"; - - for (sort keys %$files) { - my $filename = File::Spec->catfile( - $updir => lib => unicore => lib => $abbrev => "$files->{$_}.pl" - ); - - next unless -e $filename; - my ($h1, $h2) = map hex, (split(/\t/, (do $filename), 3))[0,1]; - - my $str = char_range($h1, $h2); - - for my $p ($prop_name, $abbrev) { - for my $c ($files->{$_}, $_) { - is($str =~ /(\p{$p: $c}+)/ && $1, substr($str, 0, -1)); - is($str =~ /(\P{$p= $c}+)/ && $1, substr($str, -1)); - } - } - } -} - -# General Category and Script -for my $p ('gc', 'sc') { - while (my ($abbr) = each %{ $utf8::PropValueAlias{$p} }) { - my $filename = File::Spec->catfile( - $updir => lib => unicore => lib => gc_sc => "$utf8::PVA_abbr_map{gc_sc}{$abbr}.pl" - ); - - next unless -e $filename; - my ($h1, $h2) = map hex, (split(/\t/, (do $filename), 3))[0,1]; - - my $str = char_range($h1, $h2); - - for my $x ($p, { gc => 'General Category', sc => 'Script' }->{$p}) { - for my $y ($abbr, $utf8::PropValueAlias{$p}{$abbr}, $utf8::PVA_abbr_map{gc_sc}{$abbr}) { - is($str =~ /(\p{$x: $y}+)/ && $1, substr($str, 0, -1)); - is($str =~ /(\P{$x= $y}+)/ && $1, substr($str, -1)); - SKIP: { - skip("surrogate", 1) if $abbr eq 'cs'; - test_regexp ($str, $y); - } - } - } - } -} - -# test extra properties (ASCII_Hex_Digit, Bidi_Control, etc.) -SKIP: -{ - skip "Can't reliably derive class names from file names", 576 if $^O eq 'VMS'; - - # On case tolerant filesystems, Cf.pl will cause a -e test for cf.pl to - # return true. Try to work around this by reading the filenames explicitly - # to get a case sensitive test. N.B. This will fail if filename case is - # not preserved because you might go looking for a class name of CF or cf - # when you really want Cf. Storing case sensitive data in filenames is - # simply not portable. - - my %files; - - my $dirname = File::Spec->catdir($updir => lib => unicore => lib => 'gc_sc'); - opendir D, $dirname or die $!; - @files{readdir(D)} = (); - closedir D; - - for (keys %utf8::PA_reverse) { - my $leafname = "$utf8::PA_reverse{$_}.pl"; - next unless exists $files{$leafname}; - - my $filename = File::Spec->catfile($dirname, $leafname); - - my ($h1, $h2) = map hex, (split(/\t/, (do $filename), 3))[0,1]; - - my $str = char_range($h1, $h2); - - for my $x ('gc', 'General Category') { - print "# $filename $x $_, $utf8::PA_reverse{$_}\n"; - for my $y ($_, $utf8::PA_reverse{$_}) { - is($str =~ /(\p{$x: $y}+)/ && $1, substr($str, 0, -1)); - is($str =~ /(\P{$x= $y}+)/ && $1, substr($str, -1)); - test_regexp ($str, $y); - } - } - } -} - -# test the blocks (InFoobar) -for (grep $utf8::Canonical{$_} =~ /^In/, keys %utf8::Canonical) { - my $filename = File::Spec->catfile( - $updir => lib => unicore => lib => gc_sc => "$utf8::Canonical{$_}.pl" - ); - - next unless -e $filename; - - print "# In$_ $filename\n"; - - my ($h1, $h2) = map hex, (split(/\t/, (do $filename), 3))[0,1]; - - my $str = char_range($h1, $h2); - - my $blk = $_; - - SKIP: { - skip($blk, 2) if $blk =~ /surrogates/i; - test_regexp ($str, $blk); - $blk =~ s/^In/Block:/; - test_regexp ($str, $blk); - } -} +# The other tests that are based on looking at the generated files are now +# in t/re/uniprops.t diff --git a/t/uni/overload.t b/t/uni/overload.t index e20a3abfff..da9b07beb7 100644 --- a/t/uni/overload.t +++ b/t/uni/overload.t @@ -33,6 +33,10 @@ sub stringify { package main; +# These tests are based on characters 128-255 not having latin1, and hence +# Unicode, semantics +use legacy 'unicode8bit'; + # Bug 34297 foreach my $t ("ASCII", "B\366se") { my $length = length $t; @@ -21,6 +21,21 @@ * The main routine is yylex(), which returns the next token. */ +/* +=head1 Lexer interface + +This is the lower layer of the Perl parser, managing characters and tokens. + +=for apidoc AmU|yy_parser *|PL_parser + +Pointer to a structure encapsulating the state of the parsing operation +currently in progress. The pointer can be locally changed to perform +a nested parse without interfering with the state of an outer parse. +Individual members of C<PL_parser> have their own documentation. + +=cut +*/ + #include "EXTERN.h" #define PERL_IN_TOKE_C #include "perl.h" @@ -343,6 +358,8 @@ static struct debug_tokens { { OROP, TOKENTYPE_IVAL, "OROP" }, { OROR, TOKENTYPE_NONE, "OROR" }, { PACKAGE, TOKENTYPE_NONE, "PACKAGE" }, + { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" }, + { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" }, { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, { POSTDEC, TOKENTYPE_NONE, "POSTDEC" }, { POSTINC, TOKENTYPE_NONE, "POSTINC" }, @@ -754,6 +771,698 @@ Perl_lex_end(pTHX) } /* +=for apidoc AmxU|SV *|PL_parser-E<gt>linestr + +Buffer scalar containing the chunk currently under consideration of the +text currently being lexed. This is always a plain string scalar (for +which C<SvPOK> is true). It is not intended to be used as a scalar by +normal scalar means; instead refer to the buffer directly by the pointer +variables described below. + +The lexer maintains various C<char*> pointers to things in the +C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever +reallocated, all of these pointers must be updated. Don't attempt to +do this manually, but rather use L</lex_grow_linestr> if you need to +reallocate the buffer. + +The content of the text chunk in the buffer is commonly exactly one +complete line of input, up to and including a newline terminator, +but there are situations where it is otherwise. The octets of the +buffer may be intended to be interpreted as either UTF-8 or Latin-1. +The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8> +flag on this scalar, which may disagree with it. + +For direct examination of the buffer, the variable +L</PL_parser-E<gt>bufend> points to the end of the buffer. The current +lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use +of these pointers is usually preferable to examination of the scalar +through normal scalar means. + +=for apidoc AmxU|char *|PL_parser-E<gt>bufend + +Direct pointer to the end of the chunk of text currently being lexed, the +end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr) ++ SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is +always located at the end of the buffer, and does not count as part of +the buffer's contents. + +=for apidoc AmxU|char *|PL_parser-E<gt>bufptr + +Points to the current position of lexing inside the lexer buffer. +Characters around this point may be freely examined, within +the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and +L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be +interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>. + +Lexing code (whether in the Perl core or not) moves this pointer past +the characters that it consumes. It is also expected to perform some +bookkeeping whenever a newline character is consumed. This movement +can be more conveniently performed by the function L</lex_read_to>, +which handles newlines appropriately. + +Interpretation of the buffer's octets can be abstracted out by +using the slightly higher-level functions L</lex_peek_unichar> and +L</lex_read_unichar>. + +=for apidoc AmxU|char *|PL_parser-E<gt>linestart + +Points to the start of the current line inside the lexer buffer. +This is useful for indicating at which column an error occurred, and +not much else. This must be updated by any lexing code that consumes +a newline; the function L</lex_read_to> handles this detail. + +=cut +*/ + +/* +=for apidoc Amx|bool|lex_bufutf8 + +Indicates whether the octets in the lexer buffer +(L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding +of Unicode characters. If not, they should be interpreted as Latin-1 +characters. This is analogous to the C<SvUTF8> flag for scalars. + +In UTF-8 mode, it is not guaranteed that the lexer buffer actually +contains valid UTF-8. Lexing code must be robust in the face of invalid +encoding. + +The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar +is significant, but not the whole story regarding the input character +encoding. Normally, when a file is being read, the scalar contains octets +and its C<SvUTF8> flag is off, but the octets should be interpreted as +UTF-8 if the C<use utf8> pragma is in effect. During a string eval, +however, the scalar may have the C<SvUTF8> flag on, and in this case its +octets should be interpreted as UTF-8 unless the C<use bytes> pragma +is in effect. This logic may change in the future; use this function +instead of implementing the logic yourself. + +=cut +*/ + +bool +Perl_lex_bufutf8(pTHX) +{ + return UTF; +} + +/* +=for apidoc Amx|char *|lex_grow_linestr|STRLEN len + +Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate +at least I<len> octets (including terminating NUL). Returns a +pointer to the reallocated buffer. This is necessary before making +any direct modification of the buffer that would increase its length. +L</lex_stuff_pvn> provides a more convenient way to insert text into +the buffer. + +Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>; +this function updates all of the lexer's variables that point directly +into the buffer. + +=cut +*/ + +char * +Perl_lex_grow_linestr(pTHX_ STRLEN len) +{ + SV *linestr; + char *buf; + STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos; + STRLEN linestart_pos, last_uni_pos, last_lop_pos; + linestr = PL_parser->linestr; + buf = SvPVX(linestr); + if (len <= SvLEN(linestr)) + return buf; + bufend_pos = PL_parser->bufend - buf; + bufptr_pos = PL_parser->bufptr - buf; + oldbufptr_pos = PL_parser->oldbufptr - buf; + oldoldbufptr_pos = PL_parser->oldoldbufptr - buf; + linestart_pos = PL_parser->linestart - buf; + last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0; + last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0; + buf = sv_grow(linestr, len); + PL_parser->bufend = buf + bufend_pos; + PL_parser->bufptr = buf + bufptr_pos; + PL_parser->oldbufptr = buf + oldbufptr_pos; + PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; + PL_parser->linestart = buf + linestart_pos; + if (PL_parser->last_uni) + PL_parser->last_uni = buf + last_uni_pos; + if (PL_parser->last_lop) + PL_parser->last_lop = buf + last_lop_pos; + return buf; +} + +/* +=for apidoc Amx|void|lex_stuff_pvn|char *pv|STRLEN len|U32 flags + +Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>), +immediately after the current lexing point (L</PL_parser-E<gt>bufptr>), +reallocating the buffer if necessary. This means that lexing code that +runs later will see the characters as if they had appeared in the input. +It is not recommended to do this as part of normal parsing, and most +uses of this facility run the risk of the inserted characters being +interpreted in an unintended manner. + +The string to be inserted is represented by I<len> octets starting +at I<pv>. These octets are interpreted as either UTF-8 or Latin-1, +according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>. +The characters are recoded for the lexer buffer, according to how the +buffer is currently being interpreted (L</lex_bufutf8>). If a string +to be interpreted is available as a Perl scalar, the L</lex_stuff_sv> +function is more convenient. + +=cut +*/ + +void +Perl_lex_stuff_pvn(pTHX_ char *pv, STRLEN len, U32 flags) +{ + char *bufptr; + PERL_ARGS_ASSERT_LEX_STUFF_PVN; + if (flags & ~(LEX_STUFF_UTF8)) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn"); + if (UTF) { + if (flags & LEX_STUFF_UTF8) { + goto plain_copy; + } else { + STRLEN highhalf = 0; + char *p, *e = pv+len; + for (p = pv; p != e; p++) + highhalf += !!(((U8)*p) & 0x80); + if (!highhalf) + goto plain_copy; + lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf); + bufptr = PL_parser->bufptr; + Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char); + PL_parser->bufend += len+highhalf; + for (p = pv; p != e; p++) { + U8 c = (U8)*p; + if (c & 0x80) { + *bufptr++ = (char)(0xc0 | (c >> 6)); + *bufptr++ = (char)(0x80 | (c & 0x3f)); + } else { + *bufptr++ = (char)c; + } + } + } + } else { + if (flags & LEX_STUFF_UTF8) { + STRLEN highhalf = 0; + char *p, *e = pv+len; + for (p = pv; p != e; p++) { + U8 c = (U8)*p; + if (c >= 0xc4) { + Perl_croak(aTHX_ "Lexing code attempted to stuff " + "non-Latin-1 character into Latin-1 input"); + } else if (c >= 0xc2 && p+1 != e && + (((U8)p[1]) & 0xc0) == 0x80) { + p++; + highhalf++; + } else if (c >= 0x80) { + /* malformed UTF-8 */ + ENTER; + SAVESPTR(PL_warnhook); + PL_warnhook = PERL_WARNHOOK_FATAL; + utf8n_to_uvuni((U8*)p, e-p, NULL, 0); + LEAVE; + } + } + if (!highhalf) + goto plain_copy; + lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf); + bufptr = PL_parser->bufptr; + Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char); + PL_parser->bufend += len-highhalf; + for (p = pv; p != e; p++) { + U8 c = (U8)*p; + if (c & 0x80) { + *bufptr++ = (char)(((c & 0x3) << 6) | (p[1] & 0x3f)); + p++; + } else { + *bufptr++ = (char)c; + } + } + } else { + plain_copy: + lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len); + bufptr = PL_parser->bufptr; + Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char); + PL_parser->bufend += len; + Copy(pv, bufptr, len, char); + } + } +} + +/* +=for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags + +Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>), +immediately after the current lexing point (L</PL_parser-E<gt>bufptr>), +reallocating the buffer if necessary. This means that lexing code that +runs later will see the characters as if they had appeared in the input. +It is not recommended to do this as part of normal parsing, and most +uses of this facility run the risk of the inserted characters being +interpreted in an unintended manner. + +The string to be inserted is the string value of I<sv>. The characters +are recoded for the lexer buffer, according to how the buffer is currently +being interpreted (L</lex_bufutf8>). If a string to be interpreted is +not already a Perl scalar, the L</lex_stuff_pvn> function avoids the +need to construct a scalar. + +=cut +*/ + +void +Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags) +{ + char *pv; + STRLEN len; + PERL_ARGS_ASSERT_LEX_STUFF_SV; + if (flags) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv"); + pv = SvPV(sv, len); + lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0)); +} + +/* +=for apidoc Amx|void|lex_unstuff|char *ptr + +Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to +I<ptr>. Text following I<ptr> will be moved, and the buffer shortened. +This hides the discarded text from any lexing code that runs later, +as if the text had never appeared. + +This is not the normal way to consume lexed text. For that, use +L</lex_read_to>. + +=cut +*/ + +void +Perl_lex_unstuff(pTHX_ char *ptr) +{ + char *buf, *bufend; + STRLEN unstuff_len; + PERL_ARGS_ASSERT_LEX_UNSTUFF; + buf = PL_parser->bufptr; + if (ptr < buf) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff"); + if (ptr == buf) + return; + bufend = PL_parser->bufend; + if (ptr > bufend) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff"); + unstuff_len = ptr - buf; + Move(ptr, buf, bufend+1-ptr, char); + SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len); + PL_parser->bufend = bufend - unstuff_len; +} + +/* +=for apidoc Amx|void|lex_read_to|char *ptr + +Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up +to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>, +performing the correct bookkeeping whenever a newline character is passed. +This is the normal way to consume lexed text. + +Interpretation of the buffer's octets can be abstracted out by +using the slightly higher-level functions L</lex_peek_unichar> and +L</lex_read_unichar>. + +=cut +*/ + +void +Perl_lex_read_to(pTHX_ char *ptr) +{ + char *s; + PERL_ARGS_ASSERT_LEX_READ_TO; + s = PL_parser->bufptr; + if (ptr < s || ptr > PL_parser->bufend) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to"); + for (; s != ptr; s++) + if (*s == '\n') { + CopLINE_inc(PL_curcop); + PL_parser->linestart = s+1; + } + PL_parser->bufptr = ptr; +} + +/* +=for apidoc Amx|void|lex_discard_to|char *ptr + +Discards the first part of the L</PL_parser-E<gt>linestr> buffer, +up to I<ptr>. The remaining content of the buffer will be moved, and +all pointers into the buffer updated appropriately. I<ptr> must not +be later in the buffer than the position of L</PL_parser-E<gt>bufptr>: +it is not permitted to discard text that has yet to be lexed. + +Normally it is not necessarily to do this directly, because it suffices to +use the implicit discarding behaviour of L</lex_next_chunk> and things +based on it. However, if a token stretches across multiple lines, +and the lexing code has kept multiple lines of text in the buffer fof +that purpose, then after completion of the token it would be wise to +explicitly discard the now-unneeded earlier lines, to avoid future +multi-line tokens growing the buffer without bound. + +=cut +*/ + +void +Perl_lex_discard_to(pTHX_ char *ptr) +{ + char *buf; + STRLEN discard_len; + PERL_ARGS_ASSERT_LEX_DISCARD_TO; + buf = SvPVX(PL_parser->linestr); + if (ptr < buf) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to"); + if (ptr == buf) + return; + if (ptr > PL_parser->bufptr) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to"); + discard_len = ptr - buf; + if (PL_parser->oldbufptr < ptr) + PL_parser->oldbufptr = ptr; + if (PL_parser->oldoldbufptr < ptr) + PL_parser->oldoldbufptr = ptr; + if (PL_parser->last_uni && PL_parser->last_uni < ptr) + PL_parser->last_uni = NULL; + if (PL_parser->last_lop && PL_parser->last_lop < ptr) + PL_parser->last_lop = NULL; + Move(ptr, buf, PL_parser->bufend+1-ptr, char); + SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len); + PL_parser->bufend -= discard_len; + PL_parser->bufptr -= discard_len; + PL_parser->oldbufptr -= discard_len; + PL_parser->oldoldbufptr -= discard_len; + if (PL_parser->last_uni) + PL_parser->last_uni -= discard_len; + if (PL_parser->last_lop) + PL_parser->last_lop -= discard_len; +} + +/* +=for apidoc Amx|bool|lex_next_chunk|U32 flags + +Reads in the next chunk of text to be lexed, appending it to +L</PL_parser-E<gt>linestr>. This should be called when lexing code has +looked to the end of the current chunk and wants to know more. It is +usual, but not necessary, for lexing to have consumed the entirety of +the current chunk at this time. + +If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current +chunk (i.e., the current chunk has been entirely consumed), normally the +current chunk will be discarded at the same time that the new chunk is +read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk +will not be discarded. If the current chunk has not been entirely +consumed, then it will not be discarded regardless of the flag. + +Returns true if some new text was added to the buffer, or false if the +buffer has reached the end of the input text. + +=cut +*/ + +#define LEX_FAKE_EOF 0x80000000 + +bool +Perl_lex_next_chunk(pTHX_ U32 flags) +{ + SV *linestr; + char *buf; + STRLEN old_bufend_pos, new_bufend_pos; + STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos; + STRLEN linestart_pos, last_uni_pos, last_lop_pos; + bool got_some_for_debugger = 0; + bool got_some; + if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF)) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk"); + linestr = PL_parser->linestr; + buf = SvPVX(linestr); + if (!(flags & LEX_KEEP_PREVIOUS) && + PL_parser->bufptr == PL_parser->bufend) { + old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0; + linestart_pos = 0; + if (PL_parser->last_uni != PL_parser->bufend) + PL_parser->last_uni = NULL; + if (PL_parser->last_lop != PL_parser->bufend) + PL_parser->last_lop = NULL; + last_uni_pos = last_lop_pos = 0; + *buf = 0; + SvCUR(linestr) = 0; + } else { + old_bufend_pos = PL_parser->bufend - buf; + bufptr_pos = PL_parser->bufptr - buf; + oldbufptr_pos = PL_parser->oldbufptr - buf; + oldoldbufptr_pos = PL_parser->oldoldbufptr - buf; + linestart_pos = PL_parser->linestart - buf; + last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0; + last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0; + } + if (flags & LEX_FAKE_EOF) { + goto eof; + } else if (!PL_parser->rsfp) { + got_some = 0; + } else if (filter_gets(linestr, old_bufend_pos)) { + got_some = 1; + got_some_for_debugger = 1; + } else { + if (!SvPOK(linestr)) /* can get undefined by filter_gets */ + sv_setpvs(linestr, ""); + eof: + /* End of real input. Close filehandle (unless it was STDIN), + * then add implicit termination. + */ + if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin()) + PerlIO_clearerr(PL_parser->rsfp); + else if (PL_parser->rsfp) + (void)PerlIO_close(PL_parser->rsfp); + PL_parser->rsfp = NULL; + PL_doextract = FALSE; +#ifdef PERL_MAD + if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n)) + PL_faketokens = 1; +#endif + if (!PL_in_eval && PL_minus_p) { + sv_catpvs(linestr, + /*{*/";}continue{print or die qq(-p destination: $!\\n);}"); + PL_minus_n = PL_minus_p = 0; + } else if (!PL_in_eval && PL_minus_n) { + sv_catpvs(linestr, /*{*/";}"); + PL_minus_n = 0; + } else + sv_catpvs(linestr, ";"); + got_some = 1; + } + buf = SvPVX(linestr); + new_bufend_pos = SvCUR(linestr); + PL_parser->bufend = buf + new_bufend_pos; + PL_parser->bufptr = buf + bufptr_pos; + PL_parser->oldbufptr = buf + oldbufptr_pos; + PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; + PL_parser->linestart = buf + linestart_pos; + if (PL_parser->last_uni) + PL_parser->last_uni = buf + last_uni_pos; + if (PL_parser->last_lop) + PL_parser->last_lop = buf + last_lop_pos; + if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) && + PL_curstash != PL_debstash) { + /* debugger active and we're not compiling the debugger code, + * so store the line into the debugger's array of lines + */ + update_debugger_info(NULL, buf+old_bufend_pos, + new_bufend_pos-old_bufend_pos); + } + return got_some; +} + +/* +=for apidoc Amx|I32|lex_peek_unichar|U32 flags + +Looks ahead one (Unicode) character in the text currently being lexed. +Returns the codepoint (unsigned integer value) of the next character, +or -1 if lexing has reached the end of the input text. To consume the +peeked character, use L</lex_read_unichar>. + +If the next character is in (or extends into) the next chunk of input +text, the next chunk will be read in. Normally the current chunk will be +discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> +then the current chunk will not be discarded. + +If the input is being interpreted as UTF-8 and a UTF-8 encoding error +is encountered, an exception is generated. + +=cut +*/ + +I32 +Perl_lex_peek_unichar(pTHX_ U32 flags) +{ + char *s, *bufend; + if (flags & ~(LEX_KEEP_PREVIOUS)) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar"); + s = PL_parser->bufptr; + bufend = PL_parser->bufend; + if (UTF) { + U8 head; + I32 unichar; + STRLEN len, retlen; + if (s == bufend) { + if (!lex_next_chunk(flags)) + return -1; + s = PL_parser->bufptr; + bufend = PL_parser->bufend; + } + head = (U8)*s; + if (!(head & 0x80)) + return head; + if (head & 0x40) { + len = PL_utf8skip[head]; + while ((STRLEN)(bufend-s) < len) { + if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS)) + break; + s = PL_parser->bufptr; + bufend = PL_parser->bufend; + } + } + unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY); + if (retlen == (STRLEN)-1) { + /* malformed UTF-8 */ + ENTER; + SAVESPTR(PL_warnhook); + PL_warnhook = PERL_WARNHOOK_FATAL; + utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0); + LEAVE; + } + return unichar; + } else { + if (s == bufend) { + if (!lex_next_chunk(flags)) + return -1; + s = PL_parser->bufptr; + } + return (U8)*s; + } +} + +/* +=for apidoc Amx|I32|lex_read_unichar|U32 flags + +Reads the next (Unicode) character in the text currently being lexed. +Returns the codepoint (unsigned integer value) of the character read, +and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1 +if lexing has reached the end of the input text. To non-destructively +examine the next character, use L</lex_peek_unichar> instead. + +If the next character is in (or extends into) the next chunk of input +text, the next chunk will be read in. Normally the current chunk will be +discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> +then the current chunk will not be discarded. + +If the input is being interpreted as UTF-8 and a UTF-8 encoding error +is encountered, an exception is generated. + +=cut +*/ + +I32 +Perl_lex_read_unichar(pTHX_ U32 flags) +{ + I32 c; + if (flags & ~(LEX_KEEP_PREVIOUS)) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar"); + c = lex_peek_unichar(flags); + if (c != -1) { + if (c == '\n') + CopLINE_inc(PL_curcop); + PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr); + } + return c; +} + +/* +=for apidoc Amx|void|lex_read_space|U32 flags + +Reads optional spaces, in Perl style, in the text currently being +lexed. The spaces may include ordinary whitespace characters and +Perl-style comments. C<#line> directives are processed if encountered. +L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points +at a non-space character (or the end of the input text). + +If spaces extend into the next chunk of input text, the next chunk will +be read in. Normally the current chunk will be discarded at the same +time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current +chunk will not be discarded. + +=cut +*/ + +void +Perl_lex_read_space(pTHX_ U32 flags) +{ + char *s, *bufend; + bool need_incline = 0; + if (flags & ~(LEX_KEEP_PREVIOUS)) + Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space"); +#ifdef PERL_MAD + if (PL_skipwhite) { + sv_free(PL_skipwhite); + PL_skipwhite = NULL; + } + if (PL_madskills) + PL_skipwhite = newSVpvs(""); +#endif /* PERL_MAD */ + s = PL_parser->bufptr; + bufend = PL_parser->bufend; + while (1) { + char c = *s; + if (c == '#') { + do { + c = *++s; + } while (!(c == '\n' || (c == 0 && s == bufend))); + } else if (c == '\n') { + s++; + PL_parser->linestart = s; + if (s == bufend) + need_incline = 1; + else + incline(s); + } else if (isSPACE(c)) { + s++; + } else if (c == 0 && s == bufend) { + bool got_more; +#ifdef PERL_MAD + if (PL_madskills) + sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr); +#endif /* PERL_MAD */ + PL_parser->bufptr = s; + CopLINE_inc(PL_curcop); + got_more = lex_next_chunk(flags); + CopLINE_dec(PL_curcop); + s = PL_parser->bufptr; + bufend = PL_parser->bufend; + if (!got_more) + break; + if (need_incline && PL_parser->rsfp) { + incline(s); + need_incline = 0; + } + } else { + break; + } + } +#ifdef PERL_MAD + if (PL_madskills) + sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr); +#endif /* PERL_MAD */ + PL_parser->bufptr = s; +} + +/* * S_incline * This subroutine has nothing to do with tilting, whether at windmills * or pinball tables. Its name is short for "increment line". It @@ -992,177 +1701,44 @@ S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len) STATIC char * S_skipspace(pTHX_ register char *s) { - dVAR; #ifdef PERL_MAD - int curoff; - int startoff = s - SvPVX(PL_linestr); - + char *start = s; +#endif /* PERL_MAD */ PERL_ARGS_ASSERT_SKIPSPACE; - +#ifdef PERL_MAD if (PL_skipwhite) { sv_free(PL_skipwhite); - PL_skipwhite = 0; + PL_skipwhite = NULL; } -#endif - PERL_ARGS_ASSERT_SKIPSPACE; - +#endif /* PERL_MAD */ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; -#ifdef PERL_MAD - goto done; -#else - return s; -#endif - } - for (;;) { - STRLEN prevlen; - SSize_t oldprevlen, oldoldprevlen; - SSize_t oldloplen = 0, oldunilen = 0; - while (s < PL_bufend && isSPACE(*s)) { - if (*s++ == '\n' && PL_in_eval && !PL_rsfp) - incline(s); - } - - /* comment */ - if (s < PL_bufend && *s == '#') { - while (s < PL_bufend && *s != '\n') - s++; - if (s < PL_bufend) { + } else if (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE) { + while (isSPACE(*s) && *s != '\n') + s++; + if (*s == '#') { + do { s++; - if (PL_in_eval && !PL_rsfp) { - incline(s); - continue; - } - } + } while (s != PL_bufend && *s != '\n'); } - - /* only continue to recharge the buffer if we're at the end - * of the buffer, we're not reading from a source filter, and - * we're in normal lexing mode - */ - if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat || - PL_lex_state == LEX_FORMLINE) -#ifdef PERL_MAD - goto done; -#else - return s; -#endif - - /* try to recharge the buffer */ -#ifdef PERL_MAD - curoff = s - SvPVX(PL_linestr); -#endif - - if ((s = filter_gets(PL_linestr, (prevlen = SvCUR(PL_linestr)))) - == NULL) - { -#ifdef PERL_MAD - if (PL_madskills && curoff != startoff) { - if (!PL_skipwhite) - PL_skipwhite = newSVpvs(""); - sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff, - curoff - startoff); - } - - /* mustn't throw out old stuff yet if madpropping */ - SvCUR(PL_linestr) = curoff; - s = SvPVX(PL_linestr) + curoff; - *s = 0; - if (curoff && s[-1] == '\n') - s[-1] = ' '; -#endif - - /* end of file. Add on the -p or -n magic */ - /* XXX these shouldn't really be added here, can't set PL_faketokens */ - if (PL_minus_p) { -#ifdef PERL_MAD - sv_catpvs(PL_linestr, - ";}continue{print or die qq(-p destination: $!\\n);}"); -#else - sv_setpvs(PL_linestr, - ";}continue{print or die qq(-p destination: $!\\n);}"); -#endif - PL_minus_n = PL_minus_p = 0; - } - else if (PL_minus_n) { -#ifdef PERL_MAD - sv_catpvs(PL_linestr, ";}"); -#else - sv_setpvs(PL_linestr, ";}"); -#endif - PL_minus_n = 0; - } - else -#ifdef PERL_MAD - sv_catpvs(PL_linestr,";"); -#else - sv_setpvs(PL_linestr,";"); -#endif - - /* reset variables for next time we lex */ - PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart - = SvPVX(PL_linestr) -#ifdef PERL_MAD - + curoff -#endif - ; - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = NULL; - - /* Close the filehandle. Could be from - * STDIN, or a regular file. If we were reading code from - * STDIN (because the commandline held no -e or filename) - * then we don't close it, we reset it so the code can - * read from STDIN too. - */ - - if ((PerlIO*)PL_rsfp == PerlIO_stdin()) - PerlIO_clearerr(PL_rsfp); - else - (void)PerlIO_close(PL_rsfp); - PL_rsfp = NULL; - return s; - } - - /* not at end of file, so we only read another line */ - /* make corresponding updates to old pointers, for yyerror() */ - oldprevlen = PL_oldbufptr - PL_bufend; - oldoldprevlen = PL_oldoldbufptr - PL_bufend; - if (PL_last_uni) - oldunilen = PL_last_uni - PL_bufend; - if (PL_last_lop) - oldloplen = PL_last_lop - PL_bufend; - PL_linestart = PL_bufptr = s + prevlen; - PL_bufend = s + SvCUR(PL_linestr); + if (*s == '\n') + s++; + } else { + STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr); + PL_bufptr = s; + lex_read_space(LEX_KEEP_PREVIOUS); s = PL_bufptr; - PL_oldbufptr = s + oldprevlen; - PL_oldoldbufptr = s + oldoldprevlen; - if (PL_last_uni) - PL_last_uni = s + oldunilen; - if (PL_last_lop) - PL_last_lop = s + oldloplen; - incline(s); - - /* debugger active and we're not compiling the debugger code, - * so store the line into the debugger's array of lines - */ - if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) - update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr); + PL_bufptr = SvPVX(PL_linestr) + bufptr_pos; + if (PL_linestart > PL_bufptr) + PL_bufptr = PL_linestart; + return s; } - #ifdef PERL_MAD - done: - if (PL_madskills) { - if (!PL_skipwhite) - PL_skipwhite = newSVpvs(""); - curoff = s - SvPVX(PL_linestr); - if (curoff - startoff) - sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff, - curoff - startoff); - } + if (PL_madskills) + PL_skipwhite = newSVpvn(start, s-start); +#endif /* PERL_MAD */ return s; -#endif } /* @@ -3231,7 +3807,8 @@ S_tokenize_use(pTHX_ int is_use, char *s) { s = SKIPSPACE1(s); if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { s = force_version(s, TRUE); - if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) { + if (*s == ';' || *s == '}' + || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) { start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = NULL; force_next(WORD); @@ -3292,6 +3869,7 @@ Perl_yylex(pTHX) register char *d; STRLEN len; bool bof = FALSE; + U32 fake_eof = 0; /* orig_keyword, gvp, and gv are initialized here because * jump to the label just_a_word_zero can bypass their @@ -3700,7 +4278,7 @@ Perl_yylex(pTHX) sv_catpvs(PL_linestr, "use feature ':5." STRINGIFY(PERL_VERSION) "';"); if (PL_minus_n || PL_minus_p) { - sv_catpvs(PL_linestr, "LINE: while (<>) {"); + sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/); if (PL_minus_l) sv_catpvs(PL_linestr,"chomp;"); if (PL_minus_a) { @@ -3739,60 +4317,32 @@ Perl_yylex(pTHX) goto retry; } do { + fake_eof = 0; bof = PL_rsfp ? TRUE : FALSE; - if ((s = filter_gets(PL_linestr, 0)) == NULL) { + if (0) { fake_eof: + fake_eof = LEX_FAKE_EOF; + } + PL_bufptr = PL_bufend; + CopLINE_inc(PL_curcop); + if (!lex_next_chunk(fake_eof)) { + CopLINE_dec(PL_curcop); + s = PL_bufptr; + TOKEN(';'); /* not infinite loop because rsfp is NULL now */ + } + CopLINE_dec(PL_curcop); #ifdef PERL_MAD + if (!PL_rsfp) PL_realtokenstart = -1; #endif - if (PL_rsfp) { - if ((PerlIO *)PL_rsfp == PerlIO_stdin()) - PerlIO_clearerr(PL_rsfp); - else - (void)PerlIO_close(PL_rsfp); - PL_rsfp = NULL; - PL_doextract = FALSE; - } - if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { -#ifdef PERL_MAD - if (PL_madskills) - PL_faketokens = 1; -#endif - if (PL_minus_p) - sv_setpvs(PL_linestr, ";}continue{print;}"); - else - sv_setpvs(PL_linestr, ";}"); - PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = NULL; - PL_minus_n = PL_minus_p = 0; - goto retry; - } - PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); - PL_last_lop = PL_last_uni = NULL; - sv_setpvs(PL_linestr,""); - TOKEN(';'); /* not infinite loop because rsfp is NULL now */ - } + s = PL_bufptr; /* If it looks like the start of a BOM or raw UTF-16, * check if it in fact is. */ - else if (bof && + if (bof && PL_rsfp && (*s == 0 || *(U8*)s == 0xEF || *(U8*)s >= 0xFE || s[1] == 0)) { -#ifdef PERLIO_IS_STDIO -# ifdef __GNU_LIBRARY__ -# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */ -# define FTELL_FOR_PIPE_IS_BROKEN -# endif -# else -# ifdef __GLIBC__ -# if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */ -# define FTELL_FOR_PIPE_IS_BROKEN -# endif -# endif -# endif -#endif bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr); if (bof) { PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -3816,8 +4366,6 @@ Perl_yylex(pTHX) incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; - if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) - update_debugger_info(PL_linestr, NULL, 0); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; if (CopLINE(PL_curcop) == 1) { @@ -4298,6 +4846,9 @@ Perl_yylex(pTHX) if (!PL_in_my || PL_lex_state != LEX_NORMAL) break; PL_bufptr = s; /* update in case we back off */ + if (*s == '=') { + deprecate(":= for an empty attribute list"); + } goto grabattrs; case XATTRBLOCK: PL_expect = XBLOCK; @@ -4891,7 +5442,7 @@ Perl_yylex(pTHX) d = s; { const char tmp = *s; - if (PL_lex_state == LEX_NORMAL) + if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) s = SKIPSPACE1(s); if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) @@ -5217,6 +5768,7 @@ Perl_yylex(pTHX) case 'z': case 'Z': keylookup: { + bool anydelim; I32 tmp; orig_keyword = 0; @@ -5227,34 +5779,19 @@ Perl_yylex(pTHX) s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); /* Some keywords can be followed by any delimiter, including ':' */ - tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) || + anydelim = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) || (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') || (PL_tokenbuf[0] == 'q' && strchr("qwxr", PL_tokenbuf[1]))))); /* x::* is just a word, unless x is "CORE" */ - if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) + if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) goto just_a_word; d = s; while (d < PL_bufend && isSPACE(*d)) d++; /* no comments skipped here, or s### is misparsed */ - /* Is this a label? */ - if (!tmp && PL_expect == XSTATE - && d < PL_bufend && *d == ':' && *(d + 1) != ':') { - tmp = keyword(PL_tokenbuf, len, 0); - if (tmp) - Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf); - s = d + 1; - pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf); - CLINE; - TOKEN(LABEL); - } - else - /* Check for keywords */ - tmp = keyword(PL_tokenbuf, len, 0); - /* Is this a word before a => operator? */ if (*d == '=' && d[1] == '>') { CLINE; @@ -5265,6 +5802,47 @@ Perl_yylex(pTHX) TERM(WORD); } + /* Check for plugged-in keyword */ + { + OP *o; + int result; + char *saved_bufptr = PL_bufptr; + PL_bufptr = s; + result = CALL_FPTR(PL_keyword_plugin)(aTHX_ PL_tokenbuf, len, &o); + s = PL_bufptr; + if (result == KEYWORD_PLUGIN_DECLINE) { + /* not a plugged-in keyword */ + PL_bufptr = saved_bufptr; + } else if (result == KEYWORD_PLUGIN_STMT) { + pl_yylval.opval = o; + CLINE; + PL_expect = XSTATE; + return REPORT(PLUGSTMT); + } else if (result == KEYWORD_PLUGIN_EXPR) { + pl_yylval.opval = o; + CLINE; + PL_expect = XOPERATOR; + return REPORT(PLUGEXPR); + } else { + Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'", + PL_tokenbuf); + } + } + + /* Check for built-in keyword */ + tmp = keyword(PL_tokenbuf, len, 0); + + /* Is this a label? */ + if (!anydelim && PL_expect == XSTATE + && d < PL_bufend && *d == ':' && *(d + 1) != ':') { + if (tmp) + Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf); + s = d + 1; + pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf); + CLINE; + TOKEN(LABEL); + } + if (tmp < 0) { /* second-class keyword? */ GV *ogv = NULL; /* override (winner) */ GV *hgv = NULL; /* hidden (loser) */ @@ -5329,6 +5907,7 @@ Perl_yylex(pTHX) SV *sv; int pkgname = 0; const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); + OP *rv2cv_op; CV *cv; #ifdef PERL_MAD SV *nextPL_nextwhite = 0; @@ -5422,19 +6001,29 @@ Perl_yylex(pTHX) if (len) goto safe_bareword; - /* Do the explicit type check so that we don't need to force - the initialisation of the symbol table to have a real GV. - Beware - gv may not really be a PVGV, cv may not really be - a PVCV, (because of the space optimisations that gv_init - understands) But they're true if for this symbol there is - respectively a typeglob and a subroutine. - */ - cv = gv ? ((SvTYPE(gv) == SVt_PVGV) - /* Real typeglob, so get the real subroutine: */ - ? GvCVu(gv) - /* A proxy for a subroutine in this package? */ - : SvOK(gv) ? MUTABLE_CV(gv) : NULL) - : NULL; + cv = NULL; + { + OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc(sv)); + const_op->op_private = OPpCONST_BARE; + rv2cv_op = newCVREF(0, const_op); + } + if (rv2cv_op->op_type == OP_RV2CV && + (rv2cv_op->op_flags & OPf_KIDS)) { + OP *rv_op = cUNOPx(rv2cv_op)->op_first; + switch (rv_op->op_type) { + case OP_CONST: { + SV *sv = cSVOPx_sv(rv_op); + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) + cv = (CV*)SvRV(sv); + } break; + case OP_GV: { + GV *gv = cGVOPx_gv(rv_op); + CV *maybe_cv = GvCVu(gv); + if (maybe_cv && SvTYPE((SV*)maybe_cv) == SVt_PVCV) + cv = maybe_cv; + } break; + } + } /* See if it's the indirect object for a list operator. */ @@ -5457,8 +6046,10 @@ Perl_yylex(pTHX) /* Two barewords in a row may indicate method call. */ if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && - (tmp = intuit_method(s, gv, cv))) + (tmp = intuit_method(s, gv, cv))) { + op_free(rv2cv_op); return REPORT(tmp); + } /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ @@ -5466,7 +6057,7 @@ Perl_yylex(pTHX) if ( ( !immediate_paren && (PL_last_lop_op == OP_SORT || - ((!gv || !cv) && + (!cv && (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)))) || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0' @@ -5489,6 +6080,7 @@ Perl_yylex(pTHX) /* Is this a word before a => operator? */ if (*s == '=' && s[1] == '>' && !pkgname) { + op_free(rv2cv_op); CLINE; sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf); if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) @@ -5503,7 +6095,7 @@ Perl_yylex(pTHX) d = s + 1; while (SPACE_OR_TAB(*d)) d++; - if (*d == ')' && (sv = gv_const_sv(gv))) { + if (*d == ')' && (sv = cv_const_sv(cv))) { s = d + 1; goto its_constant; } @@ -5524,6 +6116,7 @@ Perl_yylex(pTHX) PL_thistoken = newSVpvs(""); } #endif + op_free(rv2cv_op); force_next(WORD); pl_yylval.ival = 0; TOKEN('&'); @@ -5531,7 +6124,8 @@ Perl_yylex(pTHX) /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && (!gv || !cv)) { + if ((*s == '$' || *s == '{') && !cv) { + op_free(rv2cv_op); PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_METHOD; PREBLOCK(METHOD); @@ -5541,8 +6135,10 @@ Perl_yylex(pTHX) if (!orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') - && (tmp = intuit_method(s, gv, cv))) + && (tmp = intuit_method(s, gv, cv))) { + op_free(rv2cv_op); return REPORT(tmp); + } /* Not a method, so call it a subroutine (if defined) */ @@ -5552,25 +6148,17 @@ Perl_yylex(pTHX) "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ - if ((sv = gv_const_sv(gv))) { + if ((sv = cv_const_sv(cv))) { its_constant: + op_free(rv2cv_op); SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv); ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); pl_yylval.opval->op_private = 0; TOKEN(WORD); } - /* Resolve to GV now. */ - if (SvTYPE(gv) != SVt_PVGV) { - gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV); - assert (SvTYPE(gv) == SVt_PVGV); - /* cv must have been some sort of placeholder, so - now needs replacing with a real code reference. */ - cv = GvCV(gv); - } - op_free(pl_yylval.opval); - pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + pl_yylval.opval = rv2cv_op; pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; @@ -5638,7 +6226,7 @@ Perl_yylex(pTHX) if (probable_sub) { gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV); op_free(pl_yylval.opval); - pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + pl_yylval.opval = rv2cv_op; pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; @@ -5690,6 +6278,7 @@ Perl_yylex(pTHX) } } } + op_free(rv2cv_op); safe_bareword: if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) { @@ -7051,7 +7640,7 @@ S_pending_ident(pTHX) yyerror(Perl_form(aTHX_ "No package name allowed for " "variable %s in \"our\"", PL_tokenbuf)); - tmp = allocmy(PL_tokenbuf); + tmp = allocmy(PL_tokenbuf, tokenbuf_len, 0); } else { if (has_colon) @@ -7059,7 +7648,7 @@ S_pending_ident(pTHX) PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf)); pl_yylval.opval = newOP(OP_PADANY, 0); - pl_yylval.opval->op_targ = allocmy(PL_tokenbuf); + pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, 0); return PRIVATEREF; } } @@ -7078,7 +7667,7 @@ S_pending_ident(pTHX) if (!has_colon) { if (!PL_in_my) - tmp = pad_findmy(PL_tokenbuf); + tmp = pad_findmy(PL_tokenbuf, tokenbuf_len, 0); if (tmp != NOT_IN_PAD) { /* might be an "our" variable" */ if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { @@ -11429,12 +12018,14 @@ S_scan_heredoc(pTHX_ register char *s) PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); } #endif - if (!outer || - !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart - = filter_gets(PL_linestr, 0))) { + PL_bufptr = s; + CopLINE_inc(PL_curcop); + if (!outer || !lex_next_chunk(0)) { CopLINE_set(PL_curcop, (line_t)PL_multi_start); missingterm(PL_tokenbuf); } + CopLINE_dec(PL_curcop); + s = PL_bufptr; #ifdef PERL_MAD stuffstart = s - SvPVX(PL_linestr); #endif @@ -11456,8 +12047,6 @@ S_scan_heredoc(pTHX_ register char *s) else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') PL_bufend[-1] = '\n'; #endif - if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) - update_debugger_info(PL_linestr, NULL, 0); if (*s == term && memEQ(s,PL_tokenbuf,len)) { STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); *(SvPVX(PL_linestr) + off ) = ' '; @@ -11586,7 +12175,7 @@ S_scan_inputsymbol(pTHX_ char *start) /* try to find it in the pad for this block, otherwise find add symbol table ops */ - const PADOFFSET tmp = pad_findmy(d); + const PADOFFSET tmp = pad_findmy(d, len, 0); if (tmp != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { HV * const stash = PAD_COMPNAME_OURSTASH(tmp); @@ -11942,26 +12531,17 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); } #endif - if (!PL_rsfp || - !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart - = filter_gets(PL_linestr, 0))) { + CopLINE_inc(PL_curcop); + PL_bufptr = PL_bufend; + if (!lex_next_chunk(0)) { sv_free(sv); CopLINE_set(PL_curcop, (line_t)PL_multi_start); return NULL; } + s = PL_bufptr; #ifdef PERL_MAD stuffstart = 0; #endif - /* we read a line, so increment our line counter */ - CopLINE_inc(PL_curcop); - - /* update debugger info */ - if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) - update_debugger_info(PL_linestr, NULL, 0); - - /* having changed the buffer, we must update PL_bufend */ - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = NULL; } /* at this point, we have successfully read the delimited string */ @@ -12487,6 +13067,7 @@ S_scan_formline(pTHX_ register char *s) } s = (char*)eol; if (PL_rsfp) { + bool got_some; #ifdef PERL_MAD if (PL_madskills) { if (PL_thistoken) @@ -12495,18 +13076,16 @@ S_scan_formline(pTHX_ register char *s) PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart); } #endif - s = filter_gets(PL_linestr, 0); + PL_bufptr = PL_bufend; + CopLINE_inc(PL_curcop); + got_some = lex_next_chunk(0); + CopLINE_dec(PL_curcop); + s = PL_bufptr; #ifdef PERL_MAD - tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); -#else - PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); + tokenstart = PL_bufptr; #endif - PL_bufend = PL_bufptr + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = NULL; - if (!s) { - s = PL_bufptr; + if (!got_some) break; - } } incline(s); } @@ -12790,7 +13369,7 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter)); SV *const utf8_buffer = filter; IV status = IoPAGE(filter); - const bool reverse = IoLINES(filter); + const bool reverse = (bool) IoLINES(filter); I32 retval; /* As we're automatically added, at the lowest level, and hence only called @@ -13012,6 +13591,18 @@ Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv) return (char *)s; } +int +Perl_keyword_plugin_standard(pTHX_ + char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) +{ + PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD; + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(keyword_ptr); + PERL_UNUSED_ARG(keyword_len); + PERL_UNUSED_ARG(op_ptr); + return KEYWORD_PLUGIN_DECLINE; +} + /* * Local variables: * c-indentation-style: bsd diff --git a/uconfig.sh b/uconfig.sh index f4cefcbcab..7d67f19b38 100755 --- a/uconfig.sh +++ b/uconfig.sh @@ -15,6 +15,7 @@ byteorder='1234' castflags='0' cf_by='root@localhost' cf_time='Thu Jan 1 00:00:00 GMT 1970' +charbits='8' clocktype='clock_t' cpplast='-' cppminus='-' diff --git a/universal.c b/universal.c index 4da6fc56e4..941587db63 100644 --- a/universal.c +++ b/universal.c @@ -172,8 +172,10 @@ Perl_sv_does(pTHX_ SV *sv, const char *const name) SvGETMAGIC(sv); if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) { + LEAVE; return FALSE; + } if (sv_isobject(sv)) { classname = sv_reftype(SvRV(sv),TRUE); @@ -181,8 +183,10 @@ Perl_sv_does(pTHX_ SV *sv, const char *const name) classname = SvPV_nolen(sv); } - if (strEQ(name,classname)) + if (strEQ(name,classname)) { + LEAVE; return TRUE; + } PUSHMARK(SP); XPUSHs(sv); @@ -27,7 +27,7 @@ #include "utfebcdic.h" -#else +#else /* ! EBCDIC */ START_EXTERN_C #ifdef DOINIT @@ -47,11 +47,9 @@ EXTCONST unsigned char PL_utf8skip[]; #endif END_EXTERN_C -#define UTF8SKIP(s) PL_utf8skip[*(const U8*)(s)] /* Native character to iso-8859-1 */ #define NATIVE_TO_ASCII(ch) (ch) -#define NATIVE8_TO_UNI(ch) (ch) #define ASCII_TO_NATIVE(ch) (ch) /* Transform after encoding */ #define NATIVE_TO_UTF(ch) (ch) @@ -63,7 +61,7 @@ END_EXTERN_C #define NATIVE_TO_NEED(enc,ch) (ch) #define ASCII_TO_NEED(enc,ch) (ch) -/* As there are no translations avoid the function wrapper */ +/* As there are no translations, avoid the function wrapper */ #define utf8n_to_uvchr utf8n_to_uvuni #define uvchr_to_utf8 uvuni_to_utf8 @@ -111,8 +109,8 @@ encoded character. #define UNI_IS_INVARIANT(c) (((UV)c) < 0x80) -#define UTF8_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_UTF(c)) -#define NATIVE_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_ASCII(c)) +/* Note that C0 and C1 are invalid in legal UTF8, so the lower bound of the + * below might ought to be C2 */ #define UTF8_IS_START(c) (((U8)c) >= 0xc0 && (((U8)c) <= 0xfd)) #define UTF8_IS_CONTINUATION(c) (((U8)c) >= 0x80 && (((U8)c) <= 0xbf)) #define UTF8_IS_CONTINUED(c) (((U8)c) & 0x80) @@ -124,10 +122,6 @@ encoded character. #define UTF_CONTINUATION_MARK 0x80 #define UTF_ACCUMULATION_SHIFT 6 #define UTF_CONTINUATION_MASK ((U8)0x3f) -#define UTF8_ACCUMULATE(old, new) (((old) << UTF_ACCUMULATION_SHIFT) | (((U8)new) & UTF_CONTINUATION_MASK)) - -#define UTF8_EIGHT_BIT_HI(c) ((((U8)(c))>>UTF_ACCUMULATION_SHIFT)|UTF_START_MARK(2)) -#define UTF8_EIGHT_BIT_LO(c) (((((U8)(c)))&UTF_CONTINUATION_MASK)|UTF_CONTINUATION_MARK) #ifdef HAS_QUAD #define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \ @@ -147,24 +141,51 @@ encoded character. (uv) < 0x80000000 ? 6 : 7 ) #endif +#endif /* EBCDIC vs ASCII */ + +/* Rest of these are attributes of Unicode and perl's internals rather than the + * encoding, or happen to be the same in both ASCII and EBCDIC (at least at + * this level; the macros that some of these call may have different + * definitions in the two encodings */ + +#define NATIVE8_TO_UNI(ch) NATIVE_TO_ASCII(ch) /* a clearer synonym */ + +#define UTF8_ACCUMULATE(old, new) (((old) << UTF_ACCUMULATION_SHIFT) | (((U8)new) & UTF_CONTINUATION_MASK)) + +#define UTF8SKIP(s) PL_utf8skip[*(const U8*)(s)] + +#define UTF8_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_UTF(c)) +#define NATIVE_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE8_TO_UNI(c)) + +#define MAX_PORTABLE_UTF8_TWO_BYTE 0x3FF /* constrained by EBCDIC */ + +/* The macros in the next sets are used to generate the two utf8 or utfebcdic + * bytes from an ordinal that is known to fit into two bytes; it must be less + * than 0x3FF to work across both encodings. */ +/* Nocast allows these to be used in the case label of a switch statement */ +#define UTF8_TWO_BYTE_HI_nocast(c) UTF_TO_NATIVE(((c)>>UTF_ACCUMULATION_SHIFT)|UTF_START_MARK(2)) +#define UTF8_TWO_BYTE_LO_nocast(c) UTF_TO_NATIVE(((c)&UTF_CONTINUATION_MASK)|UTF_CONTINUATION_MARK) + +#define UTF8_TWO_BYTE_HI(c) ((U8) (UTF8_TWO_BYTE_HI_nocast(c))) +#define UTF8_TWO_BYTE_LO(c) ((U8) (UTF8_TWO_BYTE_LO_nocast(c))) + +/* This name is used when the source is a single byte */ +#define UTF8_EIGHT_BIT_HI(c) UTF8_TWO_BYTE_HI((U8)(c)) +#define UTF8_EIGHT_BIT_LO(c) UTF8_TWO_BYTE_LO((U8)(c)) + /* * Note: we try to be careful never to call the isXXX_utf8() functions - * unless we're pretty sure we've seen the beginning of a UTF-8 character - * (that is, the two high bits are set). Otherwise we risk loading in the - * heavy-duty swash_init and swash_fetch routines unnecessarily. + * unless we're pretty sure we've seen the beginning of a UTF-8 or UTFEBCDIC + * character. Otherwise we risk loading in the heavy-duty swash_init and + * swash_fetch routines unnecessarily. */ -#define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || (*((const U8*)p) < 0xc0))) \ +#define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || ! UTF8_IS_START(*((const U8*)p)))) \ ? isIDFIRST(*(p)) \ : isIDFIRST_utf8((const U8*)p)) -#define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || (*((const U8*)p) < 0xc0))) \ +#define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || ! UTF8_IS_START(*((const U8*)p)))) \ ? isALNUM(*(p)) \ : isALNUM_utf8((const U8*)p)) - -#endif /* EBCDIC vs ASCII */ - -/* Rest of these are attributes of Unicode and perl's internals rather than the encoding */ - #define isIDFIRST_lazy(p) isIDFIRST_lazy_if(p,1) #define isALNUM_lazy(p) isALNUM_lazy_if(p,1) @@ -176,21 +197,18 @@ encoded character. * as a way to encode non-negative integers in a binary format. */ #define UTF8_MAXLEN UTF8_MAXBYTES -#define UTF8_MAXLEN_UCLC 3 /* Obsolete, do not use. */ -#define UTF8_MAXLEN_UCLC_MULT 39 /* Obsolete, do not use. */ -#define UTF8_MAXLEN_FOLD 3 /* Obsolete, do not use. */ -#define UTF8_MAXLEN_FOLD_MULT 39 /* Obsolete, do not use. */ - /* The maximum number of UTF-8 bytes a single Unicode character can * uppercase/lowercase/fold into; this number depends on the Unicode * version. An example of maximal expansion is the U+03B0 which * uppercases to U+03C5 U+0308 U+0301. The Unicode databases that - * tell these things are UnicodeDatabase.txt, CaseFolding.txt, and + * tell these things are UnicodeData.txt, CaseFolding.txt, and * SpecialCasing.txt. */ #define UTF8_MAXBYTES_CASE 6 #define IN_BYTES (CopHINTS_get(PL_curcop) & HINT_BYTES) #define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTES) +#define IN_UNI_8_BIT ( (! (CopHINTS_get(PL_curcop) & HINT_NOT_UNI_8_BIT)) \ + && ! IN_LOCALE_RUNTIME && ! IN_BYTES) #define UTF8_ALLOW_EMPTY 0x0001 #define UTF8_ALLOW_CONTINUATION 0x0002 @@ -235,35 +253,28 @@ encoded character. #define UTF8_IS_ASCII(c) UTF8_IS_INVARIANT(c) -#define UNICODE_LATIN_SMALL_LETTER_SHARP_S 0x00DF #define UNICODE_GREEK_CAPITAL_LETTER_SIGMA 0x03A3 #define UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA 0x03C2 #define UNICODE_GREEK_SMALL_LETTER_SIGMA 0x03C3 -#define EBCDIC_LATIN_SMALL_LETTER_SHARP_S 0x0059 - #define UNI_DISPLAY_ISPRINT 0x0001 #define UNI_DISPLAY_BACKSLASH 0x0002 #define UNI_DISPLAY_QQ (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH) #define UNI_DISPLAY_REGEX (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH) -#ifdef EBCDIC -# define ANYOF_FOLD_SHARP_S(node, input, end) \ - (ANYOF_BITMAP_TEST(node, EBCDIC_LATIN_SMALL_LETTER_SHARP_S) && \ - (ANYOF_FLAGS(node) & ANYOF_UNICODE) && \ - (ANYOF_FLAGS(node) & ANYOF_FOLD) && \ - ((end) > (input) + 1) && \ - toLOWER((input)[0]) == 's' && \ - toLOWER((input)[1]) == 's') -#else -# define ANYOF_FOLD_SHARP_S(node, input, end) \ - (ANYOF_BITMAP_TEST(node, UNICODE_LATIN_SMALL_LETTER_SHARP_S) && \ +#ifndef EBCDIC +# define LATIN_SMALL_LETTER_SHARP_S 0x00DF +# define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0x00FF +# define MICRO_SIGN 0x00B5 +#endif + +#define ANYOF_FOLD_SHARP_S(node, input, end) \ + (ANYOF_BITMAP_TEST(node, LATIN_SMALL_LETTER_SHARP_S) && \ (ANYOF_FLAGS(node) & ANYOF_UNICODE) && \ (ANYOF_FLAGS(node) & ANYOF_FOLD) && \ ((end) > (input) + 1) && \ toLOWER((input)[0]) == 's' && \ toLOWER((input)[1]) == 's') -#endif #define SHARP_S_SKIP 2 #ifdef EBCDIC diff --git a/utfebcdic.h b/utfebcdic.h index e61b4a7e9c..c3fe6036ee 100644 --- a/utfebcdic.h +++ b/utfebcdic.h @@ -12,13 +12,14 @@ * * To summarize, the way it works is: * To convert an EBCDIC character to UTF-EBCDIC: - * 1) convert to Unicode. The table in this file that does this is for + * 1) convert to Unicode. The table in this file that does this for * EBCDIC bytes is PL_e2a (with inverse PLa2e). The 'a' stands for * ASCIIish, meaning latin1. - * 2) convert that to a utf8-like string called I8 with variant characters - * occupying multiple bytes. This step is similar to the utf8-creating - * step from Unicode, but the details are different. There is a chart - * about the bit patterns in a comment later in this file. But + * 2) convert that to a utf8-like string called I8 (I stands for + * intermediate) with variant characters occupying multiple bytes. This + * step is similar to the utf8-creating step from Unicode, but the details + * are different. This transformation is called UTF8-Mod. There is a + * chart about the bit patterns in a comment later in this file. But * essentially here are the differences: * UTF8 I8 * invariant byte starts with 0 starts with 0 or 100 @@ -29,18 +30,19 @@ * in I8, far beyond the current Unicode standard's * max, as shown in the comment later in this file.) * 3) Use the table published in tr16 to convert each byte from step 2 into - * final UTF-EBCDIC. The table in this file is PL_utf2e, and its inverse - * is PL_e2utf. They are constructed so that all EBCDIC invariants remain - * invariant, but no others do. For example, the ordinal value of 'A' is - * 193 in EBCDIC, and also is 193 in UTF-EBCDIC. Step 1) converts it to - * 65, Step 2 leaves it at 65, and Step 3 converts it back to 193. As an - * example of how a variant character works, take LATIN SMALL LETTER Y - * WITH DIAERESIS, which is typicially 0xDF in EBCDIC. Step 1 converts it - * to the Unicode value, 0xFF. Step 2 converts that to two bytes = - * 11000111 10111111 = C7 BF, and Step 3 converts those to 0x8B 0x73. The - * table is constructed so that the first bytes of a variant will always - * have its upper bit set (at least in the encodings that Perl recognizes, - * and probably all). + * final UTF-EBCDIC. That table is reproduced in this file as PL_utf2e, + * and its inverse is PL_e2utf. They are constructed so that all EBCDIC + * invariants remain invariant, but no others do. For example, the + * ordinal value of 'A' is 193 in EBCDIC, and also is 193 in UTF-EBCDIC. + * Step 1) converts it to 65, Step 2 leaves it at 65, and Step 3 converts + * it back to 193. As an example of how a variant character works, take + * LATIN SMALL LETTER Y WITH DIAERESIS, which is typicially 0xDF in + * EBCDIC. Step 1 converts it to the Unicode value, 0xFF. Step 2 + * converts that to two bytes = 11000111 10111111 = C7 BF, and Step 3 + * converts those to 0x8B 0x73. The table is constructed so that the + * first byte of the final form of a variant will always have its upper + * bit set (at least in the encodings that Perl recognizes, and probably + * all). But note that the upper bit of some invariants is also 1. * * If you're starting from Unicode, skip step 1. For UTF-EBCDIC to straight * EBCDIC, reverse the steps. @@ -60,8 +62,8 @@ * There are actually 3 slightly different UTF-EBCDIC encodings in this file, * one for each of the code pages recognized by Perl. That means that there * are actually three different sets of tables, one for each code page. (If - * Perl is compiled on platforms using other EBCDIC code pages, it may not - * compile, or silently mistake it for one of the three.) + * Perl is compiled on platforms using another EBCDIC code page, it may not + * compile, or Perl may silently mistake it for one of the three.) * * EBCDIC characters above 0xFF are the same as Unicode in Perl's * implementation of all 3 encodings, so for those Step 1 is trivial. @@ -150,7 +152,7 @@ unsigned char PL_utf8skip[] = { * remains 'A' */ #if '^' == 95 /* if defined(__MVS__) || defined(??) (VM/ESA?) 1047 */ -EXTCONST unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (IBM-1047) */ +EXTCONST unsigned char PL_utf2e[] = { /* I8 to EBCDIC (IBM-1047) */ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x15, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F, 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61, @@ -169,7 +171,7 @@ EXTCONST unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (IBM-1047) */ 0xDC, 0xDD, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE }; -EXTCONST unsigned char PL_e2utf[] = { /* EBCDIC (IBM-1047) to UTF-8-mod */ +EXTCONST unsigned char PL_e2utf[] = { /* EBCDIC (IBM-1047) to I8 */ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F, 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07, @@ -190,7 +192,7 @@ EXTCONST unsigned char PL_e2utf[] = { /* EBCDIC (IBM-1047) to UTF-8-mod */ #endif /* 1047 */ #if '^' == 106 /* if defined(_OSD_POSIX) POSIX-BC */ -unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (POSIX-BC) */ +unsigned char PL_utf2e[] = { /* I8 to EBCDIC (POSIX-BC) */ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x15, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F, 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61, @@ -209,7 +211,7 @@ unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (POSIX-BC) */ 0xDC, 0xC0, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xDD, 0xFC, 0xE0, 0xFE }; -unsigned char PL_e2utf[] = { /* EBCDIC (POSIX-BC) to UTF-8-mod */ +unsigned char PL_e2utf[] = { /* EBCDIC (POSIX-BC) to I8 */ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F, 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07, @@ -230,7 +232,7 @@ unsigned char PL_e2utf[] = { /* EBCDIC (POSIX-BC) to UTF-8-mod */ #endif /* POSIX-BC */ #if '^' == 176 /* if defined(??) (OS/400?) 037 */ -unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (IBM-037) */ +unsigned char PL_utf2e[] = { /* I8 to EBCDIC (IBM-037) */ 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F, 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61, @@ -249,7 +251,7 @@ unsigned char PL_utf2e[] = { /* UTF-8-mod to EBCDIC (IBM-037) */ 0xDC, 0xDD, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE }; -unsigned char PL_e2utf[] = { /* EBCDIC (IBM-037) to UTF-8-mod */ +unsigned char PL_e2utf[] = { /* EBCDIC (IBM-037) to I8 */ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x9D, 0x85, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F, 0x80, 0x81, 0x82, 0x83, 0x84, 0x0A, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07, @@ -293,6 +295,10 @@ EXTCONST unsigned char PL_a2e[] = { /* ASCII (iso-8859-1) to EBCDIC (IBM-1047) * 0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xDD, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF }; +#define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0xDF +#define LATIN_SMALL_LETTER_SHARP_S 0x59 +#define MICRO_SIGN 0xA0 + EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (IBM-1047) to ASCII (iso-8859-1) */ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F, @@ -333,6 +339,10 @@ EXTCONST unsigned char PL_a2e[] = { /* ASCII (ISO8859-1) to EBCDIC (POSIX-BC) */ 0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xC0, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF }; +#define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0xDF +#define LATIN_SMALL_LETTER_SHARP_S 0x59 +#define MICRO_SIGN 0xA0 + EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (POSIX-BC) to ASCII (ISO8859-1) */ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F, @@ -373,6 +383,11 @@ EXTCONST unsigned char PL_a2e[] = { /* ASCII (ISO8859-1) to EBCDIC (IBM-037) */ 0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xDD, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF }; + +#define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0xDF +#define LATIN_SMALL_LETTER_SHARP_S 0x59 +#define MICRO_SIGN 0xA0 + EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (IBM-037) to ASCII (ISO8859-1) */ 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x9D, 0x85, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F, @@ -403,13 +418,10 @@ EXTCONST unsigned char PL_a2e[]; END_EXTERN_C -#define UTF8SKIP(s) PL_utf8skip[*(const U8*)(s)] - /* EBCDIC-happy ways of converting native code to UTF-8 */ /* Native to iso-8859-1 */ #define NATIVE_TO_ASCII(ch) PL_e2a[(U8)(ch)] -#define NATIVE8_TO_UNI(ch) NATIVE_TO_ASCII(ch) /* synonym */ #define ASCII_TO_NATIVE(ch) PL_a2e[(U8)(ch)] /* Transform after encoding */ #define NATIVE_TO_UTF(ch) PL_e2utf[(U8)(ch)] @@ -422,21 +434,7 @@ END_EXTERN_C #define ASCII_TO_NEED(enc,ch) ((enc) ? UTF_TO_NATIVE(ch) : ASCII_TO_NATIVE(ch)) /* - * Note: we should try and be careful never to call the isXXX_utf8() functions - * unless we're pretty sure we've seen the beginning of a UTF-EBCDIC character - * Otherwise we risk loading in the heavy-duty swash_init and swash_fetch - * routines unnecessarily. - */ - -#define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || UTF8_IS_INVARIANT(*p))) \ - ? isIDFIRST(*(p)) \ - : isIDFIRST_utf8((const U8*)p)) -#define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || UTF8_IS_INVARIANT(*p))) \ - ? isALNUM(*(p)) \ - : isALNUM_utf8((const U8*)p)) - -/* - The following table is adapted from tr16, it shows UTF-8-mod encoding of Unicode code points. + The following table is adapted from tr16, it shows I8 encoding of Unicode code points. Unicode Bit pattern 1st Byte 2nd Byte 3rd Byte 4th Byte 5th Byte 6th Byte 7th byte U+0000..U+007F 000000000xxxxxxx 0xxxxxxx @@ -450,7 +448,7 @@ END_EXTERN_C U+400000..U+3FFFFFF 0uvvvvvwwwwwzzzzzyyyyyxxxxx 1111110u 101vvvvv 101wwwww 101zzzzz 101yyyyy 101xxxxx U+4000000..U+7FFFFFFF 0tuuuuuvvvvvwwwwwzzzzzyyyyyxxxxx 1111111t 101uuuuu 101vvvvv 101wwwww 101zzzzz 101yyyyy 101xxxxx - Note: The UTF-8-Mod transformation is valid for UCS-4 values X'0' to + Note: The I8 transformation is valid for UCS-4 values X'0' to X'7FFFFFFF' (the full extent of ISO/IEC 10646 coding space). */ @@ -464,9 +462,7 @@ END_EXTERN_C #define UNI_IS_INVARIANT(c) ((c) < 0xA0) -/* UTF-EBCDIC sematic macros - transform back into UTF-8-Mod and then compare */ -#define NATIVE_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE8_TO_UNI(c)) -#define UTF8_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_UTF(c)) +/* UTF-EBCDIC semantic macros - transform back into I8 and then compare */ #define UTF8_IS_START(c) (NATIVE_TO_UTF(c) >= 0xA0 && (NATIVE_TO_UTF(c) & 0xE0) != 0xA0) #define UTF8_IS_CONTINUATION(c) ((NATIVE_TO_UTF(c) & 0xE0) == 0xA0) #define UTF8_IS_CONTINUED(c) (NATIVE_TO_UTF(c) >= 0xA0) @@ -478,12 +474,6 @@ END_EXTERN_C #define UTF_CONTINUATION_MASK ((U8)0x1f) #define UTF_ACCUMULATION_SHIFT 5 -#define UTF8_ACCUMULATE(old, new) (((old) << UTF_ACCUMULATION_SHIFT)|(NATIVE_TO_UTF(new) & UTF_CONTINUATION_MASK)) - -/* UTF-EBCDIC encode a downgradeable value */ -#define UTF8_EIGHT_BIT_HI(c) UTF_TO_NATIVE((((U8)(c))>>UTF_ACCUMULATION_SHIFT)|UTF_START_MARK(2)) -#define UTF8_EIGHT_BIT_LO(c) UTF_TO_NATIVE(((((U8)(c)))&UTF_CONTINUATION_MASK)|UTF_CONTINUATION_MARK) - /* * Local variables: * c-indentation-style: bsd @@ -1364,8 +1364,7 @@ S_vdie(pTHX_ const char* pat, va_list *args) message = vdie_croak_common(pat, args); - PL_restartop = die_where(message); - JMPENV_JUMP(3); + die_where(message); /* NOTREACHED */ return NULL; } @@ -1403,13 +1402,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) msv = S_vdie_croak_common(aTHX_ pat, args); - if (PL_in_eval) { - PL_restartop = die_where(msv); - JMPENV_JUMP(3); - } - - write_to_stderr( msv ? msv : ERRSV ); - my_failure_exit(); + die_where(msv); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1564,12 +1557,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) assert(msv); S_vdie_common(aTHX_ msv, FALSE); } - if (PL_in_eval) { - PL_restartop = die_where(msv); - JMPENV_JUMP(3); - } - write_to_stderr(msv); - my_failure_exit(); + die_where(msv); } else { Perl_vwarn(aTHX_ pat, args); @@ -5378,7 +5366,7 @@ Perl_get_hash_seed(pTHX) * help. Sum in another random number that will * fill in the low bits. */ myseed += - (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); + (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1)); #endif /* RANDBITS < (UVSIZE * 8) */ if (myseed == 0) { /* Superparanoia. */ myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 428d9bb99d..8564577428 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -2100,6 +2100,9 @@ print EX <<_END_; # change 'tests => $tests' to 'tests => last_test_to_print'; +use strict; +use warnings; + _END_ my $test_mod = 'Test::More'; diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 9df77fe682..c015e25510 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -871,7 +871,7 @@ sub NowWhat { You have finished composing your message. At this point, you have a few options. You can: - * [Se]end the message to $address$andcc, + * [Se]nd the message to $address$andcc, * [D]isplay the message on the screen, * [R]e-edit the message * Display or change the message's [su]bject @@ -1134,7 +1134,7 @@ sub _send_message_mailsend { open(REP, "<$filename") or die "Couldn't open '$filename': $!\n"; while (<REP>) { print $fh $_ } close(REP) or die "Error closing $filename: $!"; - $fh->close; + $fh->close or die "Error sending mail: $!"; print "\nMessage sent.\n"; } @@ -1159,9 +1159,15 @@ sub _probe_for_sendmail { sub _send_message_sendmail { my $sendmail = _probe_for_sendmail(); unless ($sendmail) { - paraprint(<<"EOF"), die "\n"; + my $message_start = !$Is_Linux && !$Is_OpenBSD ? <<'EOT' : <<'EOT'; It appears that there is no program which looks like "sendmail" on your system and that the Mail::Send library from CPAN isn't available. +EOT +It appears that there is no program which looks like "sendmail" on +your system. +EOT + paraprint(<<"EOF"), die "\n"; +$message_start Because of this, there's no easy way to automatically send your message. diff --git a/utils/perlivp.PL b/utils/perlivp.PL index 762b4b3872..97832613ee 100644 --- a/utils/perlivp.PL +++ b/utils/perlivp.PL @@ -210,9 +210,13 @@ if (defined($Config{'extensions'})) { } # that's a distribution name, not a module name next if $_ eq 'IO/Compress'; - next if $_ eq 'Devel/DProf'; + next if $_ eq 'Devel/DProf'; + next if $_ eq 'libnet'; + next if $_ eq 'Locale/Codes'; + next if $_ eq 'podlators'; # test modules next if $_ eq 'XS/APItest'; + next if $_ eq 'XS/APItest/KeywordRPN'; next if $_ eq 'XS/Typemap'; # VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@" # \NT> perl -e "eval \"require 'Devel/DProf.pm'\"; print $@" diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 55a065060d..06fc44940e 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -401,23 +401,23 @@ extra.pods : miniperl @ @extra_pods.com pod0 = [.lib.pods]perl.pod [.lib.pods]perl5004delta.pod [.lib.pods]perl5005delta.pod [.lib.pods]perl5100delta.pod [.lib.pods]perl5101delta.pod -pod1 = [.lib.pods]perl5110delta.pod [.lib.pods]perl5111delta.pod [.lib.pods]perl5112delta.pod [.lib.pods]perl561delta.pod [.lib.pods]perl56delta.pod -pod2 = [.lib.pods]perl570delta.pod [.lib.pods]perl571delta.pod [.lib.pods]perl572delta.pod [.lib.pods]perl573delta.pod [.lib.pods]perl581delta.pod -pod3 = [.lib.pods]perl582delta.pod [.lib.pods]perl583delta.pod [.lib.pods]perl584delta.pod [.lib.pods]perl585delta.pod [.lib.pods]perl586delta.pod -pod4 = [.lib.pods]perl587delta.pod [.lib.pods]perl588delta.pod [.lib.pods]perl589delta.pod [.lib.pods]perl58delta.pod [.lib.pods]perl590delta.pod -pod5 = [.lib.pods]perl591delta.pod [.lib.pods]perl592delta.pod [.lib.pods]perl593delta.pod [.lib.pods]perl594delta.pod [.lib.pods]perl595delta.pod -pod6 = [.lib.pods]perlaix.pod [.lib.pods]perlamiga.pod [.lib.pods]perlapi.pod [.lib.pods]perlapio.pod [.lib.pods]perlapollo.pod [.lib.pods]perlartistic.pod -pod7 = [.lib.pods]perlbeos.pod [.lib.pods]perlbook.pod [.lib.pods]perlboot.pod [.lib.pods]perlbot.pod [.lib.pods]perlbs2000.pod [.lib.pods]perlcall.pod -pod8 = [.lib.pods]perlce.pod [.lib.pods]perlcheat.pod [.lib.pods]perlclib.pod [.lib.pods]perlcn.pod [.lib.pods]perlcommunity.pod [.lib.pods]perlcompile.pod -pod9 = [.lib.pods]perlcygwin.pod [.lib.pods]perldata.pod [.lib.pods]perldbmfilter.pod [.lib.pods]perldebguts.pod [.lib.pods]perldebtut.pod -pod10 = [.lib.pods]perldebug.pod [.lib.pods]perldelta.pod [.lib.pods]perldgux.pod [.lib.pods]perldiag.pod [.lib.pods]perldoc.pod [.lib.pods]perldos.pod -pod11 = [.lib.pods]perldsc.pod [.lib.pods]perlebcdic.pod [.lib.pods]perlembed.pod [.lib.pods]perlepoc.pod [.lib.pods]perlfaq.pod [.lib.pods]perlfaq1.pod -pod12 = [.lib.pods]perlfaq2.pod [.lib.pods]perlfaq3.pod [.lib.pods]perlfaq4.pod [.lib.pods]perlfaq5.pod [.lib.pods]perlfaq6.pod [.lib.pods]perlfaq7.pod -pod13 = [.lib.pods]perlfaq8.pod [.lib.pods]perlfaq9.pod [.lib.pods]perlfilter.pod [.lib.pods]perlfork.pod [.lib.pods]perlform.pod [.lib.pods]perlfreebsd.pod -pod14 = [.lib.pods]perlfunc.pod [.lib.pods]perlglossary.pod [.lib.pods]perlgpl.pod [.lib.pods]perlguts.pod [.lib.pods]perlhack.pod [.lib.pods]perlhaiku.pod -pod15 = [.lib.pods]perlhist.pod [.lib.pods]perlhpux.pod [.lib.pods]perlhurd.pod [.lib.pods]perlintern.pod [.lib.pods]perlintro.pod [.lib.pods]perliol.pod -pod16 = [.lib.pods]perlipc.pod [.lib.pods]perlirix.pod [.lib.pods]perljp.pod [.lib.pods]perlko.pod [.lib.pods]perllexwarn.pod [.lib.pods]perllinux.pod -pod17 = [.lib.pods]perllocale.pod [.lib.pods]perllol.pod [.lib.pods]perlmacos.pod [.lib.pods]perlmacosx.pod [.lib.pods]perlmod.pod +pod1 = [.lib.pods]perl5110delta.pod [.lib.pods]perl5111delta.pod [.lib.pods]perl5112delta.pod [.lib.pods]perl5113delta.pod [.lib.pods]perl561delta.pod +pod2 = [.lib.pods]perl56delta.pod [.lib.pods]perl570delta.pod [.lib.pods]perl571delta.pod [.lib.pods]perl572delta.pod [.lib.pods]perl573delta.pod +pod3 = [.lib.pods]perl581delta.pod [.lib.pods]perl582delta.pod [.lib.pods]perl583delta.pod [.lib.pods]perl584delta.pod [.lib.pods]perl585delta.pod +pod4 = [.lib.pods]perl586delta.pod [.lib.pods]perl587delta.pod [.lib.pods]perl588delta.pod [.lib.pods]perl589delta.pod [.lib.pods]perl58delta.pod +pod5 = [.lib.pods]perl590delta.pod [.lib.pods]perl591delta.pod [.lib.pods]perl592delta.pod [.lib.pods]perl593delta.pod [.lib.pods]perl594delta.pod +pod6 = [.lib.pods]perl595delta.pod [.lib.pods]perlaix.pod [.lib.pods]perlamiga.pod [.lib.pods]perlapi.pod [.lib.pods]perlapio.pod [.lib.pods]perlapollo.pod +pod7 = [.lib.pods]perlartistic.pod [.lib.pods]perlbeos.pod [.lib.pods]perlbook.pod [.lib.pods]perlboot.pod [.lib.pods]perlbot.pod [.lib.pods]perlbs2000.pod +pod8 = [.lib.pods]perlcall.pod [.lib.pods]perlce.pod [.lib.pods]perlcheat.pod [.lib.pods]perlclib.pod [.lib.pods]perlcn.pod [.lib.pods]perlcommunity.pod +pod9 = [.lib.pods]perlcompile.pod [.lib.pods]perlcygwin.pod [.lib.pods]perldata.pod [.lib.pods]perldbmfilter.pod [.lib.pods]perldebguts.pod +pod10 = [.lib.pods]perldebtut.pod [.lib.pods]perldebug.pod [.lib.pods]perldelta.pod [.lib.pods]perldgux.pod [.lib.pods]perldiag.pod [.lib.pods]perldoc.pod +pod11 = [.lib.pods]perldos.pod [.lib.pods]perldsc.pod [.lib.pods]perlebcdic.pod [.lib.pods]perlembed.pod [.lib.pods]perlepoc.pod [.lib.pods]perlfaq.pod +pod12 = [.lib.pods]perlfaq1.pod [.lib.pods]perlfaq2.pod [.lib.pods]perlfaq3.pod [.lib.pods]perlfaq4.pod [.lib.pods]perlfaq5.pod [.lib.pods]perlfaq6.pod +pod13 = [.lib.pods]perlfaq7.pod [.lib.pods]perlfaq8.pod [.lib.pods]perlfaq9.pod [.lib.pods]perlfilter.pod [.lib.pods]perlfork.pod [.lib.pods]perlform.pod +pod14 = [.lib.pods]perlfreebsd.pod [.lib.pods]perlfunc.pod [.lib.pods]perlglossary.pod [.lib.pods]perlgpl.pod [.lib.pods]perlguts.pod [.lib.pods]perlhack.pod +pod15 = [.lib.pods]perlhaiku.pod [.lib.pods]perlhist.pod [.lib.pods]perlhpux.pod [.lib.pods]perlhurd.pod [.lib.pods]perlintern.pod [.lib.pods]perlintro.pod +pod16 = [.lib.pods]perliol.pod [.lib.pods]perlipc.pod [.lib.pods]perlirix.pod [.lib.pods]perljp.pod [.lib.pods]perlko.pod [.lib.pods]perllexwarn.pod +pod17 = [.lib.pods]perllinux.pod [.lib.pods]perllocale.pod [.lib.pods]perllol.pod [.lib.pods]perlmacos.pod [.lib.pods]perlmacosx.pod [.lib.pods]perlmod.pod pod18 = [.lib.pods]perlmodinstall.pod [.lib.pods]perlmodlib.pod [.lib.pods]perlmodstyle.pod [.lib.pods]perlmpeix.pod [.lib.pods]perlmroapi.pod pod19 = [.lib.pods]perlnetware.pod [.lib.pods]perlnewmod.pod [.lib.pods]perlnumber.pod [.lib.pods]perlobj.pod [.lib.pods]perlop.pod pod20 = [.lib.pods]perlopenbsd.pod [.lib.pods]perlopentut.pod [.lib.pods]perlos2.pod [.lib.pods]perlos390.pod [.lib.pods]perlos400.pod @@ -428,13 +428,14 @@ pod24 = [.lib.pods]perlrepository.pod [.lib.pods]perlrequick.pod [.lib.pods]perl pod25 = [.lib.pods]perlrun.pod [.lib.pods]perlsec.pod [.lib.pods]perlsolaris.pod [.lib.pods]perlstyle.pod [.lib.pods]perlsub.pod [.lib.pods]perlsymbian.pod pod26 = [.lib.pods]perlsyn.pod [.lib.pods]perlthrtut.pod [.lib.pods]perltie.pod [.lib.pods]perltoc.pod [.lib.pods]perltodo.pod [.lib.pods]perltooc.pod pod27 = [.lib.pods]perltoot.pod [.lib.pods]perltrap.pod [.lib.pods]perltru64.pod [.lib.pods]perltw.pod [.lib.pods]perlunicode.pod [.lib.pods]perlunifaq.pod -pod28 = [.lib.pods]perluniintro.pod [.lib.pods]perlunitut.pod [.lib.pods]perlutil.pod [.lib.pods]perluts.pod [.lib.pods]perlvar.pod [.lib.pods]perlvmesa.pod -pod29 = [.lib.pods]perlvms.pod [.lib.pods]perlvos.pod [.lib.pods]perlwin32.pod [.lib.pods]perlxs.pod [.lib.pods]perlxstut.pod -pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21) $(pod22) $(pod23) $(pod24) $(pod25) $(pod26) $(pod27) $(pod28) $(pod29) +pod28 = [.lib.pods]perluniintro.pod [.lib.pods]perluniprops.pod [.lib.pods]perlunitut.pod [.lib.pods]perlutil.pod [.lib.pods]perluts.pod +pod29 = [.lib.pods]perlvar.pod [.lib.pods]perlvmesa.pod [.lib.pods]perlvms.pod [.lib.pods]perlvos.pod [.lib.pods]perlwin32.pod [.lib.pods]perlxs.pod +pod30 = [.lib.pods]perlxstut.pod +pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21) $(pod22) $(pod23) $(pod24) $(pod25) $(pod26) $(pod27) $(pod28) $(pod29) $(pod30) # Would be useful to automate the generation of this rule from pod/buildtoc # Plus its corresponding delete in the clean target. -[.pod]perldelta.pod : [.pod]perl5100delta.pod +[.pod]perldelta.pod : [.pod]perl5113delta.pod Copy/NoConfirm/Log $(MMS$SOURCE) $(MMS$TARGET) [.pod]perlapi.pod : embed.fnc autodoc.pl $(MINIPERL_EXE) @@ -555,7 +556,7 @@ $(ARCHDIR)vmspipe.com : vmspipe.com Copy $(MMS$SOURCE) $(ARCHDIR) unidatafiles.ts : $(MINIPERL_EXE) [.lib]Config.pm [.lib.unicore]mktables nonxsext - $(MINIPERL) [.lib.unicore]mktables "-C" [.lib.unicore] + $(MINIPERL) [.lib.unicore]mktables "-C" [.lib.unicore] "-P" [.pod] "-makelist" "-maketest" "-p" @ If F$Search("$(MMS$TARGET)").nes."" Then Delete/NoLog/NoConfirm $(MMS$TARGET);* @ Copy/NoConfirm _NLA0: $(MMS$TARGET) @@ -758,6 +759,10 @@ makeppport : $(MINIPERL_EXE) $(ARCHDIR)Config.pm nonxsext @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods] Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods] +[.lib.pods]perl5113delta.pod : [.pod]perl5113delta.pod + @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods] + Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods] + [.lib.pods]perl561delta.pod : [.pod]perl561delta.pod @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods] Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods] @@ -1346,6 +1351,10 @@ makeppport : $(MINIPERL_EXE) $(ARCHDIR)Config.pm nonxsext @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods] Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods] +[.lib.pods]perluniprops.pod : [.pod]perluniprops.pod + @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods] + Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods] + [.lib.pods]perlunitut.pod : [.pod]perlunitut.pod @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods] Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods] @@ -1846,6 +1855,7 @@ clean : tidy cleantest - If F$Search("[.pod]perlintern.pod").nes."" Then Delete/NoConfirm/Log [.pod]perlintern.pod;* - If F$Search("[.pod]perlmodlib.pod").nes."" Then Delete/NoConfirm/Log [.pod]perlmodlib.pod;* - If F$Search("[.pod]perltoc.pod").nes."" Then Delete/NoConfirm/Log [.pod]perltoc.pod;* + - If F$Search("[.pod]perluniprops.pod").nes."" Then Delete/NoConfirm/Log [.pod]perluniprops.pod;* - @extra_pods CLEAN - If F$Search("unpushed.h").nes."" Then Delete/NoConfirm/Log unpushed.h;* - If F$Search("[.lib]Config_git.pl").nes."" Then Delete/NoConfirm/Log [.lib]Config_git.pl;* @@ -11289,7 +11289,8 @@ int my_fclose(FILE *fp) { int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest) { - register char *cp, *end, *cpd, *data; + register char *cp, *end, *cpd; + char *data; register unsigned int fd = fileno(dest); register unsigned int fdoff = fd / sizeof(unsigned int); int retval; diff --git a/warnings.pl b/warnings.pl index dabc97d63a..835fd7c5e4 100644 --- a/warnings.pl +++ b/warnings.pl @@ -451,7 +451,7 @@ __END__ package warnings; -our $VERSION = '1.07'; +our $VERSION = '1.08'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -529,6 +529,27 @@ Return TRUE if that warnings category is enabled in the first scope where the object is used. Otherwise returns FALSE. +=item warnings::fatal_enabled() + +Return TRUE if the warnings category with the same name as the current +package has been set to FATAL in the calling module. +Otherwise returns FALSE. + +=item warnings::fatal_enabled($category) + +Return TRUE if the warnings category C<$category> has been set to FATAL in +the calling module. +Otherwise returns FALSE. + +=item warnings::fatal_enabled($object) + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +Return TRUE if that warnings category has been set to FATAL in the first +scope where the object is used. +Otherwise returns FALSE. + =item warnings::warn($message) Print C<$message> to STDERR. @@ -756,6 +777,17 @@ sub enabled vec($callers_bitmask, $Offsets{'all'}, 1) ; } +sub fatal_enabled +{ + Croaker("Usage: warnings::fatal_enabled([category])") + unless @_ == 1 || @_ == 0 ; + + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return 0 unless defined $callers_bitmask; + return vec($callers_bitmask, $offset + 1, 1) || + vec($callers_bitmask, $Offsets{'all'} + 1, 1) ; +} sub warn { diff --git a/win32/FindExt.pm b/win32/FindExt.pm index 4355a1769a..fe1febd839 100644 --- a/win32/FindExt.pm +++ b/win32/FindExt.pm @@ -91,7 +91,7 @@ sub find_ext # Temporary hack to cope with smokers that are not clearing directories: next if $ext{$this_ext}; - if (has_xs_or_c("$ext_dir$item") or $this_ext eq 'IO/Compress') { + if (has_xs_or_c("$ext_dir$item")) { $ext{$this_ext} = $static{$this_ext} ? 'static' : 'dynamic'; } else { $ext{$this_ext} = 'nonxs'; diff --git a/win32/Makefile b/win32/Makefile index af921d2469..6a63d236d4 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -32,7 +32,7 @@ INST_TOP = $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -#INST_VER = \5.11.1 +#INST_VER = \5.11.2 # # Comment this out if you DON'T want your perl installation to have @@ -489,7 +489,7 @@ LIBBASEFILES = $(CRYPT_LIB) \ oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ - version.lib odbc32.lib odbccp32.lib + version.lib odbc32.lib odbccp32.lib comctl32.lib # The 64 bit Platform SDK compilers contain a runtime library that doesn't # include the buffer overrun verification code used by the /GS switch. @@ -515,6 +515,14 @@ EXEOUT_FLAG = -Fe CFLAGS_O = $(CFLAGS) $(BUILDOPT) +!IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \ + "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" +LINK_FLAGS = $(LINK_FLAGS) "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'" +!ELSE +RSC_FLAGS = -DINCLUDE_MANIFEST +!ENDIF + + #################### do not edit below this line ####################### ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ############## @@ -538,7 +546,7 @@ $(o).dll: $(EMBED_DLL_MANI) .rc.res: - $(RSC) -i.. $< + $(RSC) -i.. $(RSC_FLAGS) $< # # various targets @@ -566,16 +574,17 @@ PERLSTATIC = !ENDIF # Unicode data files generated by mktables -FIRSTUNIFILE = ..\lib\unicore\Canonical.pl -UNIDATAFILES = ..\lib\unicore\Canonical.pl ..\lib\unicore\Exact.pl \ - ..\lib\unicore\Properties ..\lib\unicore\Decomposition.pl \ +FIRSTUNIFILE = ..\lib\unicore\Decomposition.pl +UNIDATAFILES = ..\lib\unicore\Decomposition.pl \ ..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \ - ..\lib\unicore\PVA.pl + ..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst \ + ..\lib\unicore\TestProp.pl # Directories of Unicode data files generated by mktables UNIDATADIR1 = ..\lib\unicore\To UNIDATADIR2 = ..\lib\unicore\lib +PERLEXE_MANIFEST= .\perlexe.manifest PERLEXE_ICO = .\perlexe.ico PERLEXE_RES = .\perlexe.res PERLDLL_RES = @@ -955,7 +964,7 @@ $(PERLSTATICLIB): Extensions_static << $(XCOPY) $(PERLSTATICLIB) $(COREDIR) -$(PERLEXE_RES): perlexe.rc $(PERLEXE_ICO) +$(PERLEXE_RES): perlexe.rc $(PERLEXE_MANIFEST) $(PERLEXE_ICO) $(MINIMOD) : $(MINIPERL) ..\minimod.pl cd .. @@ -1106,7 +1115,7 @@ utils: $(PERLEXE) $(X2P) copy ..\README.vmesa ..\pod\perlvmesa.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod - copy ..\pod\perl5112delta.pod ..\pod\perldelta.pod + copy ..\pod\perl5113delta.pod ..\pod\perldelta.pod $(MAKE) -f ..\win32\pod.mak converters cd ..\win32 $(PERLEXE) $(PL2BAT) $(UTILS) @@ -1181,8 +1190,8 @@ distclean: realclean perlmpeix.pod perlnetware.pod perlopenbsd.pod perlos2.pod \ perlos390.pod perlos400.pod perlplan9.pod perlqnx.pod \ perlriscos.pod perlsolaris.pod perlsymbian.pod perltoc.pod \ - perltru64.pod perltw.pod perluts.pod perlvmesa.pod perlvos.pod \ - perlwin32.pod \ + perltru64.pod perltw.pod perluniprops.pod perluts.pod \ + perlvmesa.pod perlvos.pod perlwin32.pod \ pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ @@ -1195,7 +1204,7 @@ distclean: realclean -del /f ..\lib\Config_git.pl -del /f bin\*.bat -del /f perllibst.h - -del /f perl.base + -del /f $(PERLEXE_RES) perl.base -cd .. && del /s *.lib *.map *.pdb *.ilk *.bs *$(o) .exists pm_to_blib ppport.h -cd $(EXTDIR) && del /s *.def Makefile Makefile.old -cd $(DISTDIR) && del /s *.def Makefile Makefile.old @@ -1224,9 +1233,9 @@ installhtml : doc inst_lib : $(CONFIGPM) $(RCOPY) ..\lib $(INST_LIB)\*.* -$(UNIDATAFILES) : $(MINIPERL) $(CONFIGPM) ..\lib\unicore\mktables Extensions_nonxs +$(UNIDATAFILES) ..\pod\perluniprops.pod : $(MINIPERL) $(CONFIGPM) ..\lib\unicore\mktables Extensions_nonxs cd ..\lib\unicore && \ - ..\$(MINIPERL) -I.. -I..\..\cpan\Cwd\lib mktables -check $@ $(FIRSTUNIFILE) + ..\$(MINIPERL) -I.. -I..\..\cpan\Cwd\lib -I..\..\cpan\Cwd mktables -P ..\..\pod -maketest -makelist -p -check $@ $(FIRSTUNIFILE) minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils $(UNIDATAFILES) $(XCOPY) $(MINIPERL) ..\t\$(NULL) diff --git a/win32/Makefile.ce b/win32/Makefile.ce index 211a97e54a..ada1e14837 100644 --- a/win32/Makefile.ce +++ b/win32/Makefile.ce @@ -6,7 +6,7 @@ SRCDIR = .. PV = 59 -INST_VER = 5.11.1 +INST_VER = 5.11.2 # INSTALL_ROOT specifies a path where this perl will be installed on CE device INSTALL_ROOT=/netzwerk/sprache/perl @@ -535,10 +535,10 @@ CONFIGPM = ..\xlib\$(CROSS_NAME)\Config.pm MINIMOD = ..\lib\ExtUtils\Miniperl.pm # Unicode data files generated by mktables -UNIDATAFILES = ..\lib\unicore\Canonical.pl ..\lib\unicore\Exact.pl \ - ..\lib\unicore\Properties ..\lib\unicore\Decomposition.pl \ +UNIDATAFILES = ..\lib\unicore\Decomposition.pl \ ..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \ - ..\lib\unicore\PVA.pl + ..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst \ + ..\lib\unicore\TestProp.pl # Directories of Unicode data files generated by mktables UNIDATADIR1 = ..\lib\unicore\To @@ -918,7 +918,7 @@ install: all $(UNIDATAFILES) : $(HPERL) $(CONFIGPM) ..\lib\unicore\mktables cd ..\lib\unicore && \ - $(HPERL) -I.. mktables + $(HPERL) -I.. mktables -P ..\..\pod -maketest -makelist -p dist: all $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) diff --git a/win32/config.bc b/win32/config.bc index 6743f14de7..ed5654ab64 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -51,6 +51,7 @@ ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' +charbits='8' chgrp='' chmod='' chown='' diff --git a/win32/config.ce b/win32/config.ce index cee1175077..9bbbe287de 100644 --- a/win32/config.ce +++ b/win32/config.ce @@ -51,6 +51,7 @@ ccsymbols='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' +charbits='8' chgrp='' chmod='' chown='' diff --git a/win32/config.gc b/win32/config.gc index 018f17499f..5199e26d84 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -51,6 +51,7 @@ ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' +charbits='8' chgrp='' chmod='' chown='' diff --git a/win32/config.gc64nox b/win32/config.gc64nox new file mode 100644 index 0000000000..f33fba531c --- /dev/null +++ b/win32/config.gc64nox @@ -0,0 +1,1077 @@ +## Configured by: ~cf_email~ +## Target system: WIN32 +Author='' +Date='$Date' +Header='' +Id='$Id' +Locker='' +Log='$Log' +RCSfile='$RCSfile' +Revision='$Revision' +Source='' +State='' +_a='.a' +_exe='.exe' +_o='.o' +afs='false' +afsroot='/afs' +alignbytes='8' +ansi2knr='' +aphostname='' +api_revision='~PERL_API_REVISION~' +api_subversion='~PERL_API_SUBVERSION~' +api_version='~PERL_API_VERSION~' +api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~' +ar='ar' +archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' +archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' +archname64='' +archname='MSWin32' +archobjs='' +asctime_r_proto='0' +awk='awk' +baserev='5' +bash='' +bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' +binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~' +bison='' +byacc='byacc' +byteorder='1234' +c='' +castflags='0' +cat='type' +cc='gcc' +cccdlflags=' ' +ccdlflags=' ' +ccflags='-MD -DWIN32' +ccflags_uselargefiles='' +ccname='~cc~' +ccsymbols='' +ccversion='' +cf_by='nobody' +cf_email='nobody@no.where.net' +cf_time='' +chgrp='' +chmod='' +chown='' +clocktype='clock_t' +comm='' +compress='' +contains='grep' +cp='copy' +cpio='' +cpp='~cc~ -E' +cpp_stuff='42' +cppccsymbols='' +cppflags='-DWIN32' +cpplast='' +cppminus='-' +cpprun='~cc~ -E' +cppstdin='~cc~ -E' +cppsymbols='' +crypt_r_proto='0' +cryptlib='' +csh='undef' +ctermid_r_proto='0' +ctime_r_proto='0' +d_Gconvert='sprintf((b),"%.*g",(n),(x))' +d_PRIEUldbl='undef' +d_PRIFUldbl='undef' +d_PRIGUldbl='undef' +d_PRIXU64='undef' +d_PRId64='undef' +d_PRIeldbl='undef' +d_PRIfldbl='undef' +d_PRIgldbl='undef' +d_PRIi64='undef' +d_PRIo64='undef' +d_PRIu64='undef' +d_PRIx64='undef' +d_SCNfldbl='undef' +d__fwalk='undef' +d_access='define' +d_accessx='undef' +d_aintl='undef' +d_alarm='define' +d_archlib='define' +d_asctime64='undef' +d_asctime_r='undef' +d_atolf='undef' +d_atoll='define' +d_attribute_deprecated='undef' +d_attribute_format='undef' +d_attribute_malloc='undef' +d_attribute_nonnull='undef' +d_attribute_noreturn='undef' +d_attribute_pure='undef' +d_attribute_unused='undef' +d_attribute_warn_unused_result='undef' +d_bcmp='undef' +d_bcopy='undef' +d_bsd='define' +d_bsdgetpgrp='undef' +d_bsdsetpgrp='undef' +d_builtin_choose_expr='undef' +d_builtin_expect='undef' +d_bzero='undef' +d_c99_variadic_macros='undef' +d_casti32='define' +d_castneg='define' +d_charvspr='undef' +d_chown='undef' +d_chroot='undef' +d_chsize='define' +d_class='undef' +d_clearenv='undef' +d_closedir='define' +d_cmsghdr_s='undef' +d_const='define' +d_copysignl='undef' +d_cplusplus='undef' +d_crypt='undef' +d_crypt_r='undef' +d_csh='undef' +d_ctermid='undef' +d_ctermid_r='undef' +d_ctime64='undef' +d_ctime_r='undef' +d_cuserid='undef' +d_dbl_dig='define' +d_dbminitproto='undef' +d_difftime64='undef' +d_difftime='define' +d_dir_dd_fd='undef' +d_dirfd='undef' +d_dirnamlen='define' +d_dlerror='define' +d_dlopen='define' +d_dlsymun='undef' +d_dosuid='undef' +d_drand48_r='undef' +d_drand48proto='undef' +d_dup2='define' +d_eaccess='undef' +d_endgrent='undef' +d_endgrent_r='undef' +d_endhent='undef' +d_endhostent_r='undef' +d_endnent='undef' +d_endnetent_r='undef' +d_endpent='undef' +d_endprotoent_r='undef' +d_endpwent='undef' +d_endpwent_r='undef' +d_endsent='undef' +d_endservent_r='undef' +d_eofnblk='define' +d_eunice='undef' +d_faststdio='define' +d_fchdir='undef' +d_fchmod='undef' +d_fchown='undef' +d_fcntl_can_lock='undef' +d_fcntl='undef' +d_fd_macros='define' +d_fd_set='define' +d_fds_bits='define' +d_fgetpos='define' +d_finitel='undef' +d_finite='undef' +d_flexfnam='define' +d_flock='define' +d_flockproto='define' +d_fork='undef' +d_fp_class='undef' +d_fpathconf='undef' +d_fpclass='undef' +d_fpclassify='undef' +d_fpclassl='undef' +d_fpos64_t='undef' +d_frexpl='undef' +d_fs_data_s='undef' +d_fseeko='undef' +d_fsetpos='define' +d_fstatfs='undef' +d_fstatvfs='undef' +d_fsync='undef' +d_ftello='undef' +d_ftime='define' +d_futimes='undef' +d_gdbm_ndbm_h_uses_prototypes='undef' +d_gdbmndbm_h_uses_prototypes='undef' +d_getaddrinfo='undef' +d_getcwd='define' +d_getespwnam='undef' +d_getfsstat='undef' +d_getgrent='undef' +d_getgrent_r='undef' +d_getgrgid_r='undef' +d_getgrnam_r='undef' +d_getgrps='undef' +d_gethbyaddr='define' +d_gethbyname='define' +d_gethent='undef' +d_gethname='define' +d_gethostbyaddr_r='undef' +d_gethostbyname_r='undef' +d_gethostent_r='undef' +d_gethostprotos='define' +d_getitimer='undef' +d_getlogin='define' +d_getlogin_r='undef' +d_getmnt='undef' +d_getmntent='undef' +d_getnameinfo='undef' +d_getnbyaddr='undef' +d_getnbyname='undef' +d_getnent='undef' +d_getnetbyaddr_r='undef' +d_getnetbyname_r='undef' +d_getnetent_r='undef' +d_getnetprotos='undef' +d_getpagsz='undef' +d_getpbyname='define' +d_getpbynumber='define' +d_getpent='undef' +d_getpgid='undef' +d_getpgrp2='undef' +d_getpgrp='undef' +d_getppid='undef' +d_getprior='undef' +d_getprotobyname_r='undef' +d_getprotobynumber_r='undef' +d_getprotoent_r='undef' +d_getprotoprotos='define' +d_getprpwnam='undef' +d_getpwent='undef' +d_getpwent_r='undef' +d_getpwnam_r='undef' +d_getpwuid_r='undef' +d_getsbyname='define' +d_getsbyport='define' +d_getsent='undef' +d_getservbyname_r='undef' +d_getservbyport_r='undef' +d_getservent_r='undef' +d_getservprotos='define' +d_getspnam='undef' +d_getspnam_r='undef' +d_gettimeod='define' +d_gmtime64='undef' +d_gmtime_r='undef' +d_gnulibc='undef' +d_grpasswd='undef' +d_hasmntopt='undef' +d_htonl='define' +d_ilogbl='undef' +d_inc_version_list='undef' +d_index='undef' +d_inetaton='undef' +d_inetntop='undef' +d_inetpton='undef' +d_int64_t='undef' +d_isascii='define' +d_isfinite='undef' +d_isinf='undef' +d_isnan='define' +d_isnanl='undef' +d_killpg='define' +d_lchown='undef' +d_ldbl_dig='define' +d_libm_lib_version='undef' +d_link='define' +d_localtime64='undef' +d_localtime_r='undef' +d_localtime_r_needs_tzset='undef' +d_locconv='define' +d_lockf='undef' +d_longdbl='define' +d_longlong='define' +d_lseekproto='define' +d_lstat='undef' +d_madvise='undef' +d_malloc_good_size='undef' +d_malloc_size='undef' +d_mblen='define' +d_mbstowcs='define' +d_mbtowc='define' +d_memchr='define' +d_memcmp='define' +d_memcpy='define' +d_memmove='define' +d_memset='define' +d_mkdir='define' +d_mkdtemp='undef' +d_mkfifo='undef' +d_mkstemp='undef' +d_mkstemps='undef' +d_mktime64='undef' +d_mktime='define' +d_mmap='undef' +d_modfl='undef' +d_modfl_pow32_bug='undef' +d_modflproto='undef' +d_mprotect='undef' +d_msgctl='undef' +d_msg_ctrunc='undef' +d_msg_dontroute='undef' +d_msgget='undef' +d_msghdr_s='undef' +d_msg_oob='undef' +d_msg_peek='undef' +d_msg_proxy='undef' +d_msgrcv='undef' +d_msgsnd='undef' +d_msg='undef' +d_msync='undef' +d_munmap='undef' +d_mymalloc='undef' +d_ndbm='undef' +d_ndbm_h_uses_prototypes='undef' +d_nice='undef' +d_nl_langinfo='undef' +d_nv_preserves_uv='undef' +d_nv_zero_is_allbits_zero='define' +d_off64_t='undef' +d_old_pthread_create_joinable='undef' +d_oldpthreads='undef' +d_oldsock='undef' +d_open3='undef' +d_pathconf='undef' +d_pause='define' +d_perl_otherlibdirs='undef' +d_phostname='undef' +d_pipe='define' +d_poll='undef' +d_portable='define' +d_printf_format_null='undef' +d_procselfexe='undef' +d_pseudofork='undef' +d_pthread_atfork='undef' +d_pthread_attr_setscope='undef' +d_pthread_yield='undef' +d_pwage='undef' +d_pwchange='undef' +d_pwclass='undef' +d_pwcomment='undef' +d_pwexpire='undef' +d_pwgecos='undef' +d_pwpasswd='undef' +d_pwquota='undef' +d_qgcvt='undef' +d_quad='define' +d_random_r='undef' +d_readdir64_r='undef' +d_readdir='define' +d_readdir_r='undef' +d_readlink='undef' +d_readv='undef' +d_recvmsg='undef' +d_rename='define' +d_rewinddir='define' +d_rmdir='define' +d_safebcpy='undef' +d_safemcpy='undef' +d_sanemcmp='define' +d_sbrkproto='undef' +d_scalbnl='undef' +d_sched_yield='undef' +d_scm_rights='undef' +d_seekdir='define' +d_select='define' +d_sem='undef' +d_semctl='undef' +d_semctl_semid_ds='undef' +d_semctl_semun='undef' +d_semget='undef' +d_semop='undef' +d_sendmsg='undef' +d_setegid='undef' +d_seteuid='undef' +d_setgrent='undef' +d_setgrent_r='undef' +d_setgrps='undef' +d_sethent='undef' +d_sethostent_r='undef' +d_setitimer='undef' +d_setlinebuf='undef' +d_setlocale='define' +d_setlocale_r='undef' +d_setnent='undef' +d_setnetent_r='undef' +d_setpent='undef' +d_setpgid='undef' +d_setpgrp2='undef' +d_setpgrp='undef' +d_setprior='undef' +d_setproctitle='undef' +d_setprotoent_r='undef' +d_setpwent='undef' +d_setpwent_r='undef' +d_setregid='undef' +d_setresgid='undef' +d_setresuid='undef' +d_setreuid='undef' +d_setrgid='undef' +d_setruid='undef' +d_setsent='undef' +d_setservent_r='undef' +d_setsid='undef' +d_setvbuf='define' +d_sfio='undef' +d_shm='undef' +d_shmat='undef' +d_shmatprototype='undef' +d_shmctl='undef' +d_shmdt='undef' +d_shmget='undef' +d_sigaction='undef' +d_signbit='undef' +d_sigprocmask='undef' +d_sigsetjmp='undef' +d_sitearch='define' +d_snprintf='define' +d_sockatmark='undef' +d_sockatmarkproto='undef' +d_socket='define' +d_socklen_t='undef' +d_sockpair='undef' +d_socks5_init='undef' +d_sprintf_returns_strlen='define' +d_sqrtl='undef' +d_srand48_r='undef' +d_srandom_r='undef' +d_sresgproto='undef' +d_sresuproto='undef' +d_statblks='undef' +d_statfs_f_flags='undef' +d_statfs_s='undef' +d_statvfs='undef' +d_stdio_cnt_lval='define' +d_stdio_ptr_lval='define' +d_stdio_ptr_lval_nochange_cnt='define' +d_stdio_ptr_lval_sets_cnt='undef' +d_stdio_stream_array='undef' +d_stdiobase='define' +d_stdstdio='define' +d_strchr='define' +d_strcoll='define' +d_strctcpy='define' +d_strerrm='strerror(e)' +d_strerror='define' +d_strerror_r='undef' +d_strftime='define' +d_strlcat='undef' +d_strlcpy='undef' +d_strtod='define' +d_strtol='define' +d_strtold='undef' +d_strtoll='define' +d_strtoq='undef' +d_strtoul='define' +d_strtoull='define' +d_strtouq='undef' +d_strxfrm='define' +d_suidsafe='undef' +d_symlink='undef' +d_syscall='undef' +d_syscallproto='undef' +d_sysconf='undef' +d_sysernlst='' +d_syserrlst='define' +d_system='define' +d_tcgetpgrp='undef' +d_tcsetpgrp='undef' +d_telldir='define' +d_telldirproto='define' +d_time='define' +d_timegm='undef' +d_times='define' +d_tm_tm_gmtoff='undef' +d_tm_tm_zone='undef' +d_tmpnam_r='undef' +d_truncate='undef' +d_ttyname_r='undef' +d_tzname='define' +d_u32align='define' +d_ualarm='undef' +d_umask='define' +d_uname='define' +d_union_semun='define' +d_unordered='undef' +d_unsetenv='undef' +d_usleep='undef' +d_usleepproto='undef' +d_ustat='undef' +d_vendorarch='undef' +d_vendorbin='undef' +d_vendorlib='undef' +d_vendorscript='undef' +d_vfork='undef' +d_void_closedir='undef' +d_voidsig='define' +d_voidtty='' +d_volatile='define' +d_vprintf='define' +d_vsnprintf='define' +d_wait4='undef' +d_waitpid='define' +d_wcstombs='define' +d_wctomb='define' +d_writev='undef' +d_xenix='undef' +date='date' +db_hashtype='int' +db_prefixtype='int' +db_version_major='0' +db_version_minor='0' +db_version_patch='0' +defvoidused='15' +direntrytype='struct direct' +dlext='dll' +dlltool='dlltool' +dlsrc='dl_win32.xs' +doublesize='8' +drand01='(rand()/(double)((unsigned)1<<RANDBITS))' +drand48_r_proto='0' +dtrace='' +dynamic_ext='Socket IO Fcntl Opcode SDBM_File attributes' +eagain='EAGAIN' +ebcdic='undef' +echo='echo' +egrep='egrep' +emacs='' +endgrent_r_proto='0' +endhostent_r_proto='0' +endnetent_r_proto='0' +endprotoent_r_proto='0' +endpwent_r_proto='0' +endservent_r_proto='0' +eunicefix=':' +exe_ext='.exe' +expr='expr' +extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~' +extern_C='extern' +extras='' +fflushNULL='define' +fflushall='undef' +find='find' +firstmakefile='makefile' +flex='' +fpossize='8' +fpostype='fpos_t' +freetype='void' +from=':' +full_ar='' +full_csh='' +full_sed='' +gccansipedantic='' +gccosandvers='' +gccversion='' +getgrent_r_proto='0' +getgrgid_r_proto='0' +getgrnam_r_proto='0' +gethostbyaddr_r_proto='0' +gethostbyname_r_proto='0' +gethostent_r_proto='0' +getlogin_r_proto='0' +getnetbyaddr_r_proto='0' +getnetbyname_r_proto='0' +getnetent_r_proto='0' +getprotobyname_r_proto='0' +getprotobynumber_r_proto='0' +getprotoent_r_proto='0' +getpwent_r_proto='0' +getpwnam_r_proto='0' +getpwuid_r_proto='0' +getservbyname_r_proto='0' +getservbyport_r_proto='0' +getservent_r_proto='0' +getspnam_r_proto='0' +gidformat='"ld"' +gidsign='-1' +gidsize='4' +gidtype='gid_t' +glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib ' +gmake='gmake' +gmtime_r_proto='0' +gnulibc_version='' +grep='grep' +groupcat='' +groupstype='gid_t' +gzip='gzip' +h_fcntl='false' +h_sysfile='true' +hint='recommended' +hostcat='ypcat hosts' +html1dir=' ' +html1direxp='' +html3dir=' ' +html3direxp='' +i16size='2' +i16type='short' +i32size='4' +i32type='long' +i64size='8' +i64type='long long' +i8size='1' +i8type='char' +i_arpainet='define' +i_assert='define' +i_bsdioctl='' +i_crypt='undef' +i_db='undef' +i_dbm='undef' +i_dirent='define' +i_dld='undef' +i_dlfcn='define' +i_fcntl='define' +i_float='define' +i_fp='undef' +i_fp_class='undef' +i_gdbm='undef' +i_gdbm_ndbm='undef' +i_gdbmndbm='undef' +i_grp='undef' +i_ieeefp='undef' +i_inttypes='undef' +i_langinfo='undef' +i_libutil='undef' +i_limits='define' +i_locale='define' +i_machcthr='undef' +i_malloc='define' +i_mallocmalloc='undef' +i_math='define' +i_memory='undef' +i_mntent='undef' +i_ndbm='undef' +i_netdb='undef' +i_neterrno='undef' +i_netinettcp='undef' +i_niin='undef' +i_poll='undef' +i_prot='undef' +i_pthread='undef' +i_pwd='undef' +i_rpcsvcdbm='define' +i_sfio='undef' +i_sgtty='undef' +i_shadow='undef' +i_socks='undef' +i_stdarg='define' +i_stddef='define' +i_stdlib='define' +i_string='define' +i_sunmath='undef' +i_sysaccess='undef' +i_sysdir='undef' +i_sysfile='undef' +i_sysfilio='define' +i_sysin='undef' +i_sysioctl='undef' +i_syslog='undef' +i_sysmman='undef' +i_sysmode='undef' +i_sysmount='undef' +i_sysndir='undef' +i_sysparam='undef' +i_syspoll='undef' +i_sysresrc='undef' +i_syssecrt='undef' +i_sysselct='undef' +i_syssockio='undef' +i_sysstat='define' +i_sysstatfs='undef' +i_sysstatvfs='undef' +i_systime='undef' +i_systimek='undef' +i_systimes='undef' +i_systypes='define' +i_sysuio='undef' +i_sysun='undef' +i_sysutsname='undef' +i_sysvfs='undef' +i_syswait='undef' +i_termio='undef' +i_termios='undef' +i_time='define' +i_unistd='undef' +i_ustat='undef' +i_utime='define' +i_values='undef' +i_varargs='undef' +i_varhdr='varargs.h' +i_vfork='undef' +ignore_versioned_solibs='' +inc_version_list='' +inc_version_list_init='0' +incpath='' +inews='' +initialinstalllocation='' +installarchlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' +installbin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' +installhtml1dir='' +installhtml3dir='' +installhtmldir='~INST_TOP~~INST_VER~\html' +installhtmlhelpdir='~INST_TOP~~INST_VER~\htmlhelp' +installman1dir='~INST_TOP~~INST_VER~\man\man1' +installman3dir='~INST_TOP~~INST_VER~\man\man3' +installprefix='~INST_TOP~~INST_VER~' +installprefixexp='~INST_TOP~~INST_VER~' +installprivlib='~INST_TOP~~INST_VER~\lib' +installscript='~INST_TOP~~INST_VER~\bin' +installsitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~' +installsitebin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' +installsitehtml1dir='' +installsitehtml3dir='' +installsitelib='~INST_TOP~\site~INST_VER~\lib' +installsiteman1dir='' +installsiteman3dir='' +installsitescript='' +installstyle='lib' +installusrbinperl='undef' +installvendorarch='' +installvendorbin='' +installvendorhtml1dir='' +installvendorhtml3dir='' +installvendorlib='' +installvendorman1dir='' +installvendorman3dir='' +installvendorscript='' +intsize='4' +issymlink='' +ivdformat='"I64d"' +ivsize='8' +ivtype='long long' +known_extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~' +ksh='' +ld='g++' +lddlflags='-mdll ~LINK_FLAGS~' +ldflags='~LINK_FLAGS~' +ldflags_uselargefiles='' +ldlibpthname='' +less='less' +lib_ext='.a' +libc='libmsvcrt.a' +libperl='libperl.a' +libpth='' +libs='' +libsdirs='' +libsfiles='' +libsfound='' +libspath='' +libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' +libswanted_uselargefiles='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' +line='line' +lint='' +lkflags='' +ln='' +lns='copy' +localtime_r_proto='0' +locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' +loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' +longdblsize='12' +longlongsize='8' +longsize='4' +lp='' +lpr='' +ls='dir' +lseeksize='8' +lseektype='long long' +mad='undef' +madlyh='' +madlyobj='' +madlysrc='' +mail='' +mailx='' +make='dmake' +make_set_make='#' +mallocobj='malloc.o' +mallocsrc='malloc.c' +malloctype='void *' +man1dir='~INST_TOP~~INST_VER~\man\man1' +man1direxp='~INST_TOP~~INST_VER~\man\man1' +man1ext='1' +man3dir='~INST_TOP~~INST_VER~\man\man3' +man3direxp='~INST_TOP~~INST_VER~\man\man3' +man3ext='3' +mips_type='' +mistrustnm='' +mkdir='mkdir' +mmaptype='void *' +modetype='mode_t' +more='more /e' +multiarch='undef' +mv='' +myarchname='MSWin32' +mydomain='' +myhostname='' +myuname='' +n='-n' +need_va_copy='undef' +netdb_hlen_type='int' +netdb_host_type='char *' +netdb_name_type='char *' +netdb_net_type='long' +nm='nm' +nm_opt='' +nm_so_opt='' +nonxs_ext='Errno' +nroff='' +nvEUformat='"E"' +nvFUformat='"F"' +nvGUformat='"G"' +nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0' +nv_preserves_uv_bits='53' +nveformat='"e"' +nvfformat='"f"' +nvgformat='"g"' +nvsize='8' +nvtype='double' +o_nonblock='O_NONBLOCK' +obj_ext='.o' +old_pthread_create_joinable='' +optimize='-O2' +orderlib='false' +osname='MSWin32' +osvers='4.0' +otherlibdirs='' +package='perl5' +pager='more /e' +passcat='' +patchlevel='~PERL_VERSION~' +path_sep=';' +perl5='' +perl='perl' +perl_patchlevel='~PERL_PATCHLEVEL~' +perladmin='' +perllibs='~libs~' +perlpath='~INST_TOP~~INST_VER~\bin~INST_ARCH~\perl.exe' +pg='' +phostname='hostname' +pidtype='int' +plibpth='' +pmake='' +pr='' +prefix='~INST_TOP~' +prefixexp='~INST_TOP~' +privlib='~INST_TOP~~INST_VER~\lib' +privlibexp='~INST_TOP~~INST_VER~\lib' +procselfexe='' +prototype='define' +ptrsize='8' +quadkind='3' +quadtype='long long' +randbits='15' +randfunc='rand' +random_r_proto='0' +randseedtype='unsigned' +ranlib='rem' +rd_nodata='-1' +readdir64_r_proto='0' +readdir_r_proto='0' +revision='5' +rm='del' +rm_try='' +rmail='' +run='' +runnm='true' +sGMTIME_max="2147483647" +sGMTIME_min="0" +sLOCALTIME_max="2147483647" +sLOCALTIME_min="0" +sPRIEUldbl='"E"' +sPRIFUldbl='"F"' +sPRIGUldbl='"G"' +sPRIXU64='"I64X"' +sPRId64='"I64d"' +sPRIeldbl='"e"' +sPRIfldbl='"f"' +sPRIgldbl='"g"' +sPRIi64='"I64i"' +sPRIo64='"I64o"' +sPRIu64='"I64u"' +sPRIx64='"I64x"' +sSCNfldbl='"f"' +sched_yield='' +scriptdir='~INST_TOP~~INST_VER~\bin' +scriptdirexp='~INST_TOP~~INST_VER~\bin' +sed='sed' +seedfunc='srand' +selectminbits='32' +selecttype='Perl_fd_set *' +sendmail='blat' +setgrent_r_proto='0' +sethostent_r_proto='0' +setlocale_r_proto='0' +setnetent_r_proto='0' +setprotoent_r_proto='0' +setpwent_r_proto='0' +setservent_r_proto='0' +sh='cmd /x /c' +shar='' +sharpbang='#!' +shmattype='void *' +shortsize='2' +shrpenv='' +shsharp='true' +sig_count='26' +sig_name='ZERO HUP INT QUIT ILL NUM05 NUM06 NUM07 FPE KILL NUM10 SEGV NUM12 PIPE ALRM TERM NUM16 NUM17 NUM18 NUM19 CHLD BREAK ABRT STOP NUM24 CONT CLD' +sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0' +sig_num='0 1 2 21 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 20' +sig_num_init='0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0' +sig_size='27' +signal_t='void' +sitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~' +sitearchexp='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~' +sitebin='~INST_TOP~\site~INST_VER~\bin~INST_ARCH~' +sitebinexp='~INST_TOP~\site~INST_VER~\bin~INST_ARCH~' +sitehtml1dir='' +sitehtml1direxp='' +sitehtml3dir='' +sitehtml3direxp='' +sitelib='~INST_TOP~\site~INST_VER~\lib' +sitelib_stem='' +sitelibexp='~INST_TOP~\site~INST_VER~\lib' +siteman1dir='' +siteman1direxp='' +siteman3dir='' +siteman3direxp='' +siteprefix='~INST_TOP~\site~INST_VER~' +siteprefixexp='~INST_TOP~\site~INST_VER~' +sitescript='' +sitescriptexp='' +sizesize='8' +sizetype='size_t' +sleep='' +smail='' +so='dll' +sockethdr='' +socketlib='' +socksizetype='int' +sort='sort' +spackage='Perl5' +spitshell='' +srand48_r_proto='0' +srandom_r_proto='0' +src='' +ssizetype='long long' +startperl='#!perl' +startsh='#!/bin/sh' +static_ext=' ' +stdchar='char' +stdio_base='((fp)->_base)' +stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' +stdio_cnt='((fp)->_cnt)' +stdio_filbuf='' +stdio_ptr='((fp)->_ptr)' +stdio_stream_array='' +strerror_r_proto='0' +strings='/usr/include/string.h' +submit='' +subversion='~SUBVERSION~' +sysman='/usr/man/man1' +tail='' +tar='' +targetarch='' +tbl='' +tee='' +test='' +timeincl='/usr/include/sys/time.h ' +timetype='time_t' +tmpnam_r_proto='0' +to=':' +touch='touch' +tr='' +trnl='\012' +troff='' +ttyname_r_proto='0' +u16size='2' +u16type='unsigned short' +u32size='4' +u32type='unsigned long' +u64size='8' +u64type='unsigned long long' +u8size='1' +u8type='unsigned char' +uidformat='"ld"' +uidsign='-1' +uidsize='4' +uidtype='uid_t' +uname='uname' +uniq='uniq' +uquadtype='unsigned long long' +use5005threads='undef' +use64bitall='undef' +use64bitint='define' +usecrosscompile='undef' +usedevel='undef' +usedl='define' +usedtrace='undef' +usefaststdio='undef' +useithreads='undef' +uselargefiles='undef' +uselongdouble='undef' +usemallocwrap='define' +usemorebits='undef' +usemultiplicity='undef' +usemymalloc='n' +usenm='false' +useopcode='true' +useperlio='undef' +useposix='true' +usereentrant='undef' +userelocatableinc='undef' +usesfio='false' +useshrplib='true' +usesitecustomize='undef' +usesocks='undef' +usethreads='undef' +usevendorprefix='undef' +usevfork='false' +usrinc='/usr/include' +uuname='' +uvXUformat='"I64X"' +uvoformat='"I64o"' +uvsize='8' +uvtype='unsigned long long' +uvuformat='"I64u"' +uvxformat='"I64x"' +vendorarch='' +vendorarchexp='' +vendorbin='' +vendorbinexp='' +vendorhtml1dir=' ' +vendorhtml1direxp='' +vendorhtml3dir=' ' +vendorhtml3direxp='' +vendorlib='' +vendorlib_stem='' +vendorlibexp='' +vendorman1dir=' ' +vendorman1direxp='' +vendorman3dir=' ' +vendorman3direxp='' +vendorprefix='' +vendorprefixexp='' +vendorscript='' +vendorscriptexp='' +version='~VERSION~' +version_patchlevel_string='' +versiononly='undef' +vi='' +voidflags='15' +xlibpth='/usr/lib/386 /lib/386' +yacc='yacc' +yaccflags='' +zcat='' +zip='zip' +PERL_REVISION='~PERL_REVISION~' +PERL_SUBVERSION='~PERL_SUBVERSION~' +PERL_VERSION='~PERL_VERSION~' +PERL_API_REVISION='~PERL_API_REVISION~' +PERL_API_SUBVERSION='~PERL_API_SUBVERSION~' +PERL_API_VERSION='~PERL_API_VERSION~' +PERL_PATCHLEVEL='~PERL_PATCHLEVEL~' +PERL_CONFIG_SH='true' diff --git a/win32/config.vc b/win32/config.vc index e0c6354051..b66c3341f3 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -51,6 +51,7 @@ ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' +charbits='8' chgrp='' chmod='' chown='' diff --git a/win32/config.vc64 b/win32/config.vc64 index 44ab7f297c..bf80c7b1b0 100644 --- a/win32/config.vc64 +++ b/win32/config.vc64 @@ -51,6 +51,7 @@ ccversion='' cf_by='nobody' cf_email='nobody@no.where.net' cf_time='' +charbits='8' chgrp='' chmod='' chown='' diff --git a/win32/config_H.gc b/win32/config_H.gc index 823cb3e614..9899822c4d 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -991,6 +991,7 @@ */ #if 42 == 1 #define CAT2(a,b) a/**/b +#undef STRINGIFY #define STRINGIFY(a) "a" #endif #if 42 == 42 @@ -998,6 +999,7 @@ #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) +#undef STRINGIFY #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 diff --git a/win32/config_H.gc64 b/win32/config_H.gc64 index 1e5734774e..19f1eb738f 100644 --- a/win32/config_H.gc64 +++ b/win32/config_H.gc64 @@ -971,6 +971,7 @@ */ #if 42 == 1 #define CAT2(a,b) a/**/b +#undef STRINGIFY #define STRINGIFY(a) "a" #endif #if 42 == 42 @@ -978,6 +979,7 @@ #define PeRl_StGiFy(a) #a #define CAT2(a,b) PeRl_CaTiFy(a,b) #define StGiFy(a) PeRl_StGiFy(a) +#undef STRINGIFY #define STRINGIFY(a) PeRl_StGiFy(a) #endif #if 42 != 1 && 42 != 42 diff --git a/win32/config_H.gc64nox b/win32/config_H.gc64nox new file mode 100644 index 0000000000..62f9efa550 --- /dev/null +++ b/win32/config_H.gc64nox @@ -0,0 +1,4661 @@ +/* + * This file was produced by running the config_h.SH script, which + * gets its values from undef, which is generally produced by + * running Configure. + * + * Feel free to modify any of this as the need arises. Note, however, + * that running config_h.SH again will wipe out any changes you've made. + * For a more permanent change edit undef and rerun config_h.SH. + * + * $Id: Config_h.U 1 2006-08-24 12:32:52Z rmanfredi $ + */ + +/* + * Package name : perl5 + * Source directory : + * Configuration time: Fri Dec 12 15:19:23 2008 + * Configured by : shay + * Target system : + */ + +#ifndef _config_h_ +#define _config_h_ + +/* LOC_SED: + * This symbol holds the complete pathname to the sed program. + */ +#define LOC_SED "" /**/ + +/* HAS_ALARM: + * This symbol, if defined, indicates that the alarm routine is + * available. + */ +#define HAS_ALARM /**/ + +/* HAS_BCMP: + * This symbol is defined if the bcmp() routine is available to + * compare blocks of memory. + */ +/*#define HAS_BCMP /**/ + +/* HAS_BCOPY: + * This symbol is defined if the bcopy() routine is available to + * copy blocks of memory. + */ +/*#define HAS_BCOPY /**/ + +/* HAS_BZERO: + * This symbol is defined if the bzero() routine is available to + * set a memory block to 0. + */ +/*#define HAS_BZERO /**/ + +/* HAS_CHOWN: + * This symbol, if defined, indicates that the chown routine is + * available. + */ +/*#define HAS_CHOWN /**/ + +/* HAS_CHROOT: + * This symbol, if defined, indicates that the chroot routine is + * available. + */ +/*#define HAS_CHROOT /**/ + +/* HAS_CHSIZE: + * This symbol, if defined, indicates that the chsize routine is available + * to truncate files. You might need a -lx to get this routine. + */ +#define HAS_CHSIZE /**/ + +/* HAS_CRYPT: + * This symbol, if defined, indicates that the crypt routine is available + * to encrypt passwords and the like. + */ +/*#define HAS_CRYPT /**/ + +/* HAS_CTERMID: + * This symbol, if defined, indicates that the ctermid routine is + * available to generate filename for terminal. + */ +/*#define HAS_CTERMID /**/ + +/* HAS_CUSERID: + * This symbol, if defined, indicates that the cuserid routine is + * available to get character login names. + */ +/*#define HAS_CUSERID /**/ + +/* HAS_DBL_DIG: + * This symbol, if defined, indicates that this system's <float.h> + * or <limits.h> defines the symbol DBL_DIG, which is the number + * of significant digits in a double precision number. If this + * symbol is not defined, a guess of 15 is usually pretty good. + */ +#define HAS_DBL_DIG /**/ + +/* HAS_DIFFTIME: + * This symbol, if defined, indicates that the difftime routine is + * available. + */ +#define HAS_DIFFTIME /**/ + +/* HAS_DLERROR: + * This symbol, if defined, indicates that the dlerror routine is + * available to return a string describing the last error that + * occurred from a call to dlopen(), dlclose() or dlsym(). + */ +#define HAS_DLERROR /**/ + +/* HAS_DUP2: + * This symbol, if defined, indicates that the dup2 routine is + * available to duplicate file descriptors. + */ +#define HAS_DUP2 /**/ + +/* HAS_FCHMOD: + * This symbol, if defined, indicates that the fchmod routine is available + * to change mode of opened files. If unavailable, use chmod(). + */ +/*#define HAS_FCHMOD /**/ + +/* HAS_FCHOWN: + * This symbol, if defined, indicates that the fchown routine is available + * to change ownership of opened files. If unavailable, use chown(). + */ +/*#define HAS_FCHOWN /**/ + +/* HAS_FCNTL: + * This symbol, if defined, indicates to the C program that + * the fcntl() function exists. + */ +/*#define HAS_FCNTL /**/ + +/* HAS_FGETPOS: + * This symbol, if defined, indicates that the fgetpos routine is + * available to get the file position indicator, similar to ftell(). + */ +#define HAS_FGETPOS /**/ + +/* HAS_FLOCK: + * This symbol, if defined, indicates that the flock routine is + * available to do file locking. + */ +#define HAS_FLOCK /**/ + +/* HAS_FORK: + * This symbol, if defined, indicates that the fork routine is + * available. + */ +/*#define HAS_FORK /**/ + +/* HAS_FSETPOS: + * This symbol, if defined, indicates that the fsetpos routine is + * available to set the file position indicator, similar to fseek(). + */ +#define HAS_FSETPOS /**/ + +/* HAS_GETTIMEOFDAY: + * This symbol, if defined, indicates that the gettimeofday() system + * call is available for a sub-second accuracy clock. Usually, the file + * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). + * The type "Timeval" should be used to refer to "struct timeval". + */ +#define HAS_GETTIMEOFDAY /**/ +#ifdef HAS_GETTIMEOFDAY +#define Timeval struct timeval /* Structure used by gettimeofday() */ +#endif + +/* HAS_GETGROUPS: + * This symbol, if defined, indicates that the getgroups() routine is + * available to get the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +/*#define HAS_GETGROUPS /**/ + +/* HAS_GETLOGIN: + * This symbol, if defined, indicates that the getlogin routine is + * available to get the login name. + */ +#define HAS_GETLOGIN /**/ + +/* HAS_GETPGID: + * This symbol, if defined, indicates to the C program that + * the getpgid(pid) function is available to get the + * process group id. + */ +/*#define HAS_GETPGID /**/ + +/* HAS_GETPGRP2: + * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) + * routine is available to get the current process group. + */ +/*#define HAS_GETPGRP2 /**/ + +/* HAS_GETPPID: + * This symbol, if defined, indicates that the getppid routine is + * available to get the parent process ID. + */ +/*#define HAS_GETPPID /**/ + +/* HAS_GETPRIORITY: + * This symbol, if defined, indicates that the getpriority routine is + * available to get a process's priority. + */ +/*#define HAS_GETPRIORITY /**/ + +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +/*#define HAS_INET_ATON /**/ + +/* HAS_KILLPG: + * This symbol, if defined, indicates that the killpg routine is available + * to kill process groups. If unavailable, you probably should use kill + * with a negative process number. + */ +#define HAS_KILLPG /**/ + +/* HAS_LINK: + * This symbol, if defined, indicates that the link routine is + * available to create hard links. + */ +#define HAS_LINK /**/ + +/* HAS_LOCALECONV: + * This symbol, if defined, indicates that the localeconv routine is + * available for numeric and monetary formatting conventions. + */ +#define HAS_LOCALECONV /**/ + +/* HAS_LOCKF: + * This symbol, if defined, indicates that the lockf routine is + * available to do file locking. + */ +/*#define HAS_LOCKF /**/ + +/* HAS_LSTAT: + * This symbol, if defined, indicates that the lstat routine is + * available to do file stats on symbolic links. + */ +/*#define HAS_LSTAT /**/ + +/* HAS_MBLEN: + * This symbol, if defined, indicates that the mblen routine is available + * to find the number of bytes in a multibye character. + */ +#define HAS_MBLEN /**/ + +/* HAS_MBSTOWCS: + * This symbol, if defined, indicates that the mbstowcs routine is + * available to covert a multibyte string into a wide character string. + */ +#define HAS_MBSTOWCS /**/ + +/* HAS_MBTOWC: + * This symbol, if defined, indicates that the mbtowc routine is available + * to covert a multibyte to a wide character. + */ +#define HAS_MBTOWC /**/ + +/* HAS_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * to compare blocks of memory. + */ +#define HAS_MEMCMP /**/ + +/* HAS_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy blocks of memory. + */ +#define HAS_MEMCPY /**/ + +/* HAS_MEMMOVE: + * This symbol, if defined, indicates that the memmove routine is available + * to copy potentially overlapping blocks of memory. This should be used + * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your + * own version. + */ +#define HAS_MEMMOVE /**/ + +/* HAS_MEMSET: + * This symbol, if defined, indicates that the memset routine is available + * to set blocks of memory. + */ +#define HAS_MEMSET /**/ + +/* HAS_MKDIR: + * This symbol, if defined, indicates that the mkdir routine is available + * to create directories. Otherwise you should fork off a new process to + * exec /bin/mkdir. + */ +#define HAS_MKDIR /**/ + +/* HAS_MKFIFO: + * This symbol, if defined, indicates that the mkfifo routine is + * available to create FIFOs. Otherwise, mknod should be able to + * do it for you. However, if mkfifo is there, mknod might require + * super-user privileges which mkfifo will not. + */ +/*#define HAS_MKFIFO /**/ + +/* HAS_MKTIME: + * This symbol, if defined, indicates that the mktime routine is + * available. + */ +#define HAS_MKTIME /**/ + +/* HAS_MSYNC: + * This symbol, if defined, indicates that the msync system call is + * available to synchronize a mapped file. + */ +/*#define HAS_MSYNC /**/ + +/* HAS_MUNMAP: + * This symbol, if defined, indicates that the munmap system call is + * available to unmap a region, usually mapped by mmap(). + */ +/*#define HAS_MUNMAP /**/ + +/* HAS_NICE: + * This symbol, if defined, indicates that the nice routine is + * available. + */ +/*#define HAS_NICE /**/ + +/* HAS_PATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given filename. + */ +/* HAS_FPATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given open file descriptor. + */ +/*#define HAS_PATHCONF /**/ +/*#define HAS_FPATHCONF /**/ + +/* HAS_PAUSE: + * This symbol, if defined, indicates that the pause routine is + * available to suspend a process until a signal is received. + */ +#define HAS_PAUSE /**/ + +/* HAS_PIPE: + * This symbol, if defined, indicates that the pipe routine is + * available to create an inter-process channel. + */ +#define HAS_PIPE /**/ + +/* HAS_POLL: + * This symbol, if defined, indicates that the poll routine is + * available to poll active file descriptors. Please check I_POLL and + * I_SYS_POLL to know which header should be included as well. + */ +/*#define HAS_POLL /**/ + +/* HAS_READDIR: + * This symbol, if defined, indicates that the readdir routine is + * available to read directory entries. You may have to include + * <dirent.h>. See I_DIRENT. + */ +#define HAS_READDIR /**/ + +/* HAS_SEEKDIR: + * This symbol, if defined, indicates that the seekdir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_SEEKDIR /**/ + +/* HAS_TELLDIR: + * This symbol, if defined, indicates that the telldir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_TELLDIR /**/ + +/* HAS_REWINDDIR: + * This symbol, if defined, indicates that the rewinddir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_REWINDDIR /**/ + +/* HAS_READLINK: + * This symbol, if defined, indicates that the readlink routine is + * available to read the value of a symbolic link. + */ +/*#define HAS_READLINK /**/ + +/* HAS_RENAME: + * This symbol, if defined, indicates that the rename routine is available + * to rename files. Otherwise you should do the unlink(), link(), unlink() + * trick. + */ +#define HAS_RENAME /**/ + +/* HAS_RMDIR: + * This symbol, if defined, indicates that the rmdir routine is + * available to remove directories. Otherwise you should fork off a + * new process to exec /bin/rmdir. + */ +#define HAS_RMDIR /**/ + +/* HAS_SELECT: + * This symbol, if defined, indicates that the select routine is + * available to select active file descriptors. If the timeout field + * is used, <sys/time.h> may need to be included. + */ +#define HAS_SELECT /**/ + +/* HAS_SETEGID: + * This symbol, if defined, indicates that the setegid routine is available + * to change the effective gid of the current program. + */ +/*#define HAS_SETEGID /**/ + +/* HAS_SETEUID: + * This symbol, if defined, indicates that the seteuid routine is available + * to change the effective uid of the current program. + */ +/*#define HAS_SETEUID /**/ + +/* HAS_SETGROUPS: + * This symbol, if defined, indicates that the setgroups() routine is + * available to set the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +/*#define HAS_SETGROUPS /**/ + +/* HAS_SETLINEBUF: + * This symbol, if defined, indicates that the setlinebuf routine is + * available to change stderr or stdout from block-buffered or unbuffered + * to a line-buffered mode. + */ +/*#define HAS_SETLINEBUF /**/ + +/* HAS_SETLOCALE: + * This symbol, if defined, indicates that the setlocale routine is + * available to handle locale-specific ctype implementations. + */ +#define HAS_SETLOCALE /**/ + +/* HAS_SETPGID: + * This symbol, if defined, indicates that the setpgid(pid, gpid) + * routine is available to set process group ID. + */ +/*#define HAS_SETPGID /**/ + +/* HAS_SETPGRP2: + * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) + * routine is available to set the current process group. + */ +/*#define HAS_SETPGRP2 /**/ + +/* HAS_SETPRIORITY: + * This symbol, if defined, indicates that the setpriority routine is + * available to set a process's priority. + */ +/*#define HAS_SETPRIORITY /**/ + +/* HAS_SETREGID: + * This symbol, if defined, indicates that the setregid routine is + * available to change the real and effective gid of the current + * process. + */ +/* HAS_SETRESGID: + * This symbol, if defined, indicates that the setresgid routine is + * available to change the real, effective and saved gid of the current + * process. + */ +/*#define HAS_SETREGID /**/ +/*#define HAS_SETRESGID /**/ + +/* HAS_SETREUID: + * This symbol, if defined, indicates that the setreuid routine is + * available to change the real and effective uid of the current + * process. + */ +/* HAS_SETRESUID: + * This symbol, if defined, indicates that the setresuid routine is + * available to change the real, effective and saved uid of the current + * process. + */ +/*#define HAS_SETREUID /**/ +/*#define HAS_SETRESUID /**/ + +/* HAS_SETRGID: + * This symbol, if defined, indicates that the setrgid routine is available + * to change the real gid of the current program. + */ +/*#define HAS_SETRGID /**/ + +/* HAS_SETRUID: + * This symbol, if defined, indicates that the setruid routine is available + * to change the real uid of the current program. + */ +/*#define HAS_SETRUID /**/ + +/* HAS_SETSID: + * This symbol, if defined, indicates that the setsid routine is + * available to set the process group ID. + */ +/*#define HAS_SETSID /**/ + +/* HAS_STRCHR: + * This symbol is defined to indicate that the strchr()/strrchr() + * functions are available for string searching. If not, try the + * index()/rindex() pair. + */ +/* HAS_INDEX: + * This symbol is defined to indicate that the index()/rindex() + * functions are available for string searching. + */ +#define HAS_STRCHR /**/ +/*#define HAS_INDEX /**/ + +/* HAS_STRCOLL: + * This symbol, if defined, indicates that the strcoll routine is + * available to compare strings using collating information. + */ +#define HAS_STRCOLL /**/ + +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to provide better numeric string conversion than atof(). + */ +#define HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is available + * to provide better numeric string conversion than atoi() and friends. + */ +#define HAS_STRTOL /**/ + +/* HAS_STRXFRM: + * This symbol, if defined, indicates that the strxfrm() routine is + * available to transform strings. + */ +#define HAS_STRXFRM /**/ + +/* HAS_SYMLINK: + * This symbol, if defined, indicates that the symlink routine is available + * to create symbolic links. + */ +/*#define HAS_SYMLINK /**/ + +/* HAS_SYSCALL: + * This symbol, if defined, indicates that the syscall routine is + * available to call arbitrary system calls. If undefined, that's tough. + */ +/*#define HAS_SYSCALL /**/ + +/* HAS_SYSCONF: + * This symbol, if defined, indicates that sysconf() is available + * to determine system related limits and options. + */ +/*#define HAS_SYSCONF /**/ + +/* HAS_SYSTEM: + * This symbol, if defined, indicates that the system routine is + * available to issue a shell command. + */ +#define HAS_SYSTEM /**/ + +/* HAS_TCGETPGRP: + * This symbol, if defined, indicates that the tcgetpgrp routine is + * available to get foreground process group ID. + */ +/*#define HAS_TCGETPGRP /**/ + +/* HAS_TCSETPGRP: + * This symbol, if defined, indicates that the tcsetpgrp routine is + * available to set foreground process group ID. + */ +/*#define HAS_TCSETPGRP /**/ + +/* HAS_TRUNCATE: + * This symbol, if defined, indicates that the truncate routine is + * available to truncate files. + */ +/*#define HAS_TRUNCATE /**/ + +/* HAS_TZNAME: + * This symbol, if defined, indicates that the tzname[] array is + * available to access timezone names. + */ +#define HAS_TZNAME /**/ + +/* HAS_UMASK: + * This symbol, if defined, indicates that the umask routine is + * available to set and get the value of the file creation mask. + */ +#define HAS_UMASK /**/ + +/* HAS_USLEEP: + * This symbol, if defined, indicates that the usleep routine is + * available to let the process sleep on a sub-second accuracy. + */ +/*#define HAS_USLEEP /**/ + +/* HAS_WAIT4: + * This symbol, if defined, indicates that wait4() exists. + */ +/*#define HAS_WAIT4 /**/ + +/* HAS_WAITPID: + * This symbol, if defined, indicates that the waitpid routine is + * available to wait for child process. + */ +#define HAS_WAITPID /**/ + +/* HAS_WCSTOMBS: + * This symbol, if defined, indicates that the wcstombs routine is + * available to convert wide character strings to multibyte strings. + */ +#define HAS_WCSTOMBS /**/ + +/* HAS_WCTOMB: + * This symbol, if defined, indicates that the wctomb routine is available + * to covert a wide character to a multibyte. + */ +#define HAS_WCTOMB /**/ + +/* Groups_t: + * This symbol holds the type used for the second argument to + * getgroups() and setgroups(). Usually, this is the same as + * gidtype (gid_t) , but sometimes it isn't. + * It can be int, ushort, gid_t, etc... + * It may be necessary to include <sys/types.h> to get any + * typedef'ed information. This is only required if you have + * getgroups() or setgroups().. + */ +#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) +#define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ +#endif + +/* I_ARPA_INET: + * This symbol, if defined, indicates to the C program that it should + * include <arpa/inet.h> to get inet_addr and friends declarations. + */ +#define I_ARPA_INET /**/ + +/* I_DBM: + * This symbol, if defined, indicates that <dbm.h> exists and should + * be included. + */ +/* I_RPCSVC_DBM: + * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and + * should be included. + */ +/*#define I_DBM /**/ +#define I_RPCSVC_DBM /**/ + +/* I_DLFCN: + * This symbol, if defined, indicates that <dlfcn.h> exists and should + * be included. + */ +#define I_DLFCN /**/ + +/* I_FCNTL: + * This manifest constant tells the C program to include <fcntl.h>. + */ +#define I_FCNTL /**/ + +/* I_FLOAT: + * This symbol, if defined, indicates to the C program that it should + * include <float.h> to get definition of symbols like DBL_MAX or + * DBL_MIN, i.e. machine dependent floating point values. + */ +#define I_FLOAT /**/ + +/* I_GDBM: + * This symbol, if defined, indicates that <gdbm.h> exists and should + * be included. + */ +/*#define I_GDBM /**/ + +/* I_LIMITS: + * This symbol, if defined, indicates to the C program that it should + * include <limits.h> to get definition of symbols like WORD_BIT or + * LONG_MAX, i.e. machine dependant limitations. + */ +#define I_LIMITS /**/ + +/* I_LOCALE: + * This symbol, if defined, indicates to the C program that it should + * include <locale.h>. + */ +#define I_LOCALE /**/ + +/* I_MATH: + * This symbol, if defined, indicates to the C program that it should + * include <math.h>. + */ +#define I_MATH /**/ + +/* I_MEMORY: + * This symbol, if defined, indicates to the C program that it should + * include <memory.h>. + */ +/*#define I_MEMORY /**/ + +/* I_NETINET_IN: + * This symbol, if defined, indicates to the C program that it should + * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. + */ +/*#define I_NETINET_IN /**/ + +/* I_SFIO: + * This symbol, if defined, indicates to the C program that it should + * include <sfio.h>. + */ +/*#define I_SFIO /**/ + +/* I_STDDEF: + * This symbol, if defined, indicates that <stddef.h> exists and should + * be included. + */ +#define I_STDDEF /**/ + +/* I_STDLIB: + * This symbol, if defined, indicates that <stdlib.h> exists and should + * be included. + */ +#define I_STDLIB /**/ + +/* I_STRING: + * This symbol, if defined, indicates to the C program that it should + * include <string.h> (USG systems) instead of <strings.h> (BSD systems). + */ +#define I_STRING /**/ + +/* I_SYS_DIR: + * This symbol, if defined, indicates to the C program that it should + * include <sys/dir.h>. + */ +/*#define I_SYS_DIR /**/ + +/* I_SYS_FILE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/file.h> to get definition of R_OK and friends. + */ +/*#define I_SYS_FILE /**/ + +/* I_SYS_IOCTL: + * This symbol, if defined, indicates that <sys/ioctl.h> exists and should + * be included. Otherwise, include <sgtty.h> or <termio.h>. + */ +/* I_SYS_SOCKIO: + * This symbol, if defined, indicates the <sys/sockio.h> should be included + * to get socket ioctl options, like SIOCATMARK. + */ +/*#define I_SYS_IOCTL /**/ +/*#define I_SYS_SOCKIO /**/ + +/* I_SYS_NDIR: + * This symbol, if defined, indicates to the C program that it should + * include <sys/ndir.h>. + */ +/*#define I_SYS_NDIR /**/ + +/* I_SYS_PARAM: + * This symbol, if defined, indicates to the C program that it should + * include <sys/param.h>. + */ +/*#define I_SYS_PARAM /**/ + +/* I_SYS_POLL: + * This symbol, if defined, indicates that the program may include + * <sys/poll.h>. When I_POLL is also defined, it's probably safest + * to only include <poll.h>. + */ +/*#define I_SYS_POLL /**/ + +/* I_SYS_RESOURCE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/resource.h>. + */ +/*#define I_SYS_RESOURCE /**/ + +/* I_SYS_SELECT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/select.h> in order to get definition of struct timeval. + */ +/*#define I_SYS_SELECT /**/ + +/* I_SYS_STAT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/stat.h>. + */ +#define I_SYS_STAT /**/ + +/* I_SYS_TIMES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/times.h>. + */ +/*#define I_SYS_TIMES /**/ + +/* I_SYS_TYPES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/types.h>. + */ +#define I_SYS_TYPES /**/ + +/* I_SYS_UN: + * This symbol, if defined, indicates to the C program that it should + * include <sys/un.h> to get UNIX domain socket definitions. + */ +/*#define I_SYS_UN /**/ + +/* I_SYS_WAIT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/wait.h>. + */ +/*#define I_SYS_WAIT /**/ + +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * <termio.h> rather than <sgtty.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * <sgtty.h> rather than <termio.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/*#define I_TERMIO /**/ +/*#define I_TERMIOS /**/ +/*#define I_SGTTY /**/ + +/* I_UNISTD: + * This symbol, if defined, indicates to the C program that it should + * include <unistd.h>. + */ +/*#define I_UNISTD /**/ + +/* I_UTIME: + * This symbol, if defined, indicates to the C program that it should + * include <utime.h>. + */ +#define I_UTIME /**/ + +/* I_VALUES: + * This symbol, if defined, indicates to the C program that it should + * include <values.h> to get definition of symbols like MINFLOAT or + * MAXLONG, i.e. machine dependant limitations. Probably, you + * should use <limits.h> instead, if it is available. + */ +/*#define I_VALUES /**/ + +/* I_VFORK: + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +/*#define I_VFORK /**/ + +/* INTSIZE: + * This symbol contains the value of sizeof(int) so that the C + * preprocessor can make decisions based on it. + */ +/* LONGSIZE: + * This symbol contains the value of sizeof(long) so that the C + * preprocessor can make decisions based on it. + */ +/* SHORTSIZE: + * This symbol contains the value of sizeof(short) so that the C + * preprocessor can make decisions based on it. + */ +#define INTSIZE 4 /**/ +#define LONGSIZE 4 /**/ +#define SHORTSIZE 2 /**/ + +/* MULTIARCH: + * This symbol, if defined, signifies that the build + * process will produce some binary files that are going to be + * used in a cross-platform environment. This is the case for + * example with the NeXT "fat" binaries that contain executables + * for several CPUs. + */ +/*#define MULTIARCH /**/ + +/* HAS_QUAD: + * This symbol, if defined, tells that there's a 64-bit integer type, + * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one + * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T + * or QUAD_IS___INT64. + */ +#define HAS_QUAD /**/ +#ifdef HAS_QUAD +# ifdef _MSC_VER +# define Quad_t __int64 /**/ +# define Uquad_t unsigned __int64 /**/ +# define QUADKIND 5 /**/ +# else /* gcc presumably */ +# define Quad_t long long /**/ +# define Uquad_t unsigned long long /**/ +# define QUADKIND 3 /**/ +# endif +# define QUAD_IS_INT 1 +# define QUAD_IS_LONG 2 +# define QUAD_IS_LONG_LONG 3 +# define QUAD_IS_INT64_T 4 +# define QUAD_IS___INT64 5 +#endif + +/* OSNAME: + * This symbol contains the name of the operating system, as determined + * by Configure. You shouldn't rely on it too much; the specific + * feature tests from Configure are generally more reliable. + */ +/* OSVERS: + * This symbol contains the version of the operating system, as determined + * by Configure. You shouldn't rely on it too much; the specific + * feature tests from Configure are generally more reliable. + */ +#define OSNAME "MSWin32" /**/ +#define OSVERS "5.1" /**/ + +/* ARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user wants to put architecture-dependent public + * library files for perl5. It is most often a local directory + * such as /usr/local/lib. Programs using this variable must be + * prepared to deal with filename expansion. If ARCHLIB is the + * same as PRIVLIB, it is not defined, since presumably the + * program already searches PRIVLIB. + */ +/* ARCHLIB_EXP: + * 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\\lib" /**/ +/*#define ARCHLIB_EXP "" /**/ + +/* ARCHNAME: + * This symbol holds a string representing the architecture name. + * It may be used to construct an architecture-dependant pathname + * where library files may be held under a private library, for + * instance. + */ +#define ARCHNAME "MSWin32-x64" /**/ + +/* BIN: + * This symbol holds the path of the bin directory where the package will + * be installed. Program must be prepared to deal with ~name substitution. + */ +/* BIN_EXP: + * This symbol is the filename expanded version of the BIN symbol, for + * programs that do not want to deal with that at run-time. + */ +/* PERL_RELOCATABLE_INC: + * This symbol, if defined, indicates that we'd like to relocate entries + * in @INC at run time based on the location of the perl binary. + */ +#define BIN "c:\\perl\\bin" /**/ +#define BIN_EXP "c:\\perl\\bin" /**/ +#define PERL_RELOCATABLE_INC "undef" /**/ + +/* CAT2: + * This macro concatenates 2 tokens together. + */ +/* STRINGIFY: + * This macro surrounds its token with double quotes. + */ +#if 42 == 1 +#define CAT2(a,b) a/**/b +#undef STRINGIFY +#define STRINGIFY(a) "a" +#endif +#if 42 == 42 +#define PeRl_CaTiFy(a, b) a ## b +#define PeRl_StGiFy(a) #a +#define CAT2(a,b) PeRl_CaTiFy(a,b) +#define StGiFy(a) PeRl_StGiFy(a) +#undef STRINGIFY +#define STRINGIFY(a) PeRl_StGiFy(a) +#endif +#if 42 != 1 && 42 != 42 +#include "Bletch: How does this C preprocessor concatenate tokens?" +#endif + +/* CPPSTDIN: + * This symbol contains the first part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. Typical value of "cc -E" or "/lib/cpp", but it can also + * call a wrapper. See CPPRUN. + */ +/* CPPMINUS: + * This symbol contains the second part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. This symbol will have the value "-" if CPPSTDIN needs a minus + * to specify standard input, otherwise the value is "". + */ +/* CPPRUN: + * This symbol contains the string which will invoke a C preprocessor on + * the standard input and produce to standard output. It needs to end + * with CPPLAST, after all other preprocessor flags have been specified. + * The main difference with CPPSTDIN is that this program will never be a + * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is + * available directly to the user. Note that it may well be different from + * the preprocessor used to compile the C program. + */ +/* CPPLAST: + * This symbol is intended to be used along with CPPRUN in the same manner + * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". + */ +#ifdef _MSC_VER +# define CPPSTDIN "cppstdin" +# define CPPMINUS "" +# define CPPRUN "cl -nologo -E" +#else +# define CPPSTDIN "gcc -E" +# define CPPMINUS "-" +# define CPPRUN "gcc -E" +#endif +#define CPPLAST "" + +/* HAS_ACCESS: + * This manifest constant lets the C program know that the access() + * system call is available to check for accessibility using real UID/GID. + * (always present on UNIX.) + */ +#define HAS_ACCESS /**/ + +/* HAS_ACCESSX: + * This symbol, if defined, indicates that the accessx routine is + * available to do extended access checks. + */ +/*#define HAS_ACCESSX /**/ + +/* HAS_ASCTIME_R: + * This symbol, if defined, indicates that the asctime_r routine + * is available to asctime re-entrantly. + */ +/* ASCTIME_R_PROTO: + * This symbol encodes the prototype of asctime_r. + * It is zero if d_asctime_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_asctime_r + * is defined. + */ +/*#define HAS_ASCTIME_R /**/ +#define ASCTIME_R_PROTO 0 /**/ + +/* HASATTRIBUTE_FORMAT: + * Can we handle GCC attribute for checking printf-style formats + */ +/* PRINTF_FORMAT_NULL_OK: + * Allows __printf__ format to be null when checking printf-style + */ +/* HASATTRIBUTE_MALLOC: + * Can we handle GCC attribute for malloc-style functions. + */ +/* HASATTRIBUTE_NONNULL: + * Can we handle GCC attribute for nonnull function parms. + */ +/* HASATTRIBUTE_NORETURN: + * Can we handle GCC attribute for functions that do not return + */ +/* HASATTRIBUTE_PURE: + * Can we handle GCC attribute for pure functions + */ +/* HASATTRIBUTE_UNUSED: + * Can we handle GCC attribute for unused variables and arguments + */ +/* HASATTRIBUTE_DEPRECATED: + * Can we handle GCC attribute for marking deprecated APIs + */ +/* HASATTRIBUTE_WARN_UNUSED_RESULT: + * Can we handle GCC attribute for warning on unused results + */ +/*#define HASATTRIBUTE_DEPRECATED /**/ +/*#define HASATTRIBUTE_FORMAT /**/ +/*#define PRINTF_FORMAT_NULL_OK /**/ +/*#define HASATTRIBUTE_NORETURN /**/ +/*#define HASATTRIBUTE_MALLOC /**/ +/*#define HASATTRIBUTE_NONNULL /**/ +/*#define HASATTRIBUTE_PURE /**/ +/*#define HASATTRIBUTE_UNUSED /**/ +/*#define HASATTRIBUTE_WARN_UNUSED_RESULT /**/ + +/* HASCONST: + * This symbol, if defined, indicates that this C compiler knows about + * the const type. There is no need to actually test for that symbol + * within your programs. The mere use of the "const" keyword will + * trigger the necessary tests. + */ +#define HASCONST /**/ +#ifndef HASCONST +#define const +#endif + +/* HAS_CRYPT_R: + * This symbol, if defined, indicates that the crypt_r routine + * is available to crypt re-entrantly. + */ +/* CRYPT_R_PROTO: + * This symbol encodes the prototype of crypt_r. + * It is zero if d_crypt_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_crypt_r + * is defined. + */ +/*#define HAS_CRYPT_R /**/ +#define CRYPT_R_PROTO 0 /**/ + +/* HAS_CSH: + * This symbol, if defined, indicates that the C-shell exists. + */ +/* CSH: + * This symbol, if defined, contains the full pathname of csh. + */ +/*#define HAS_CSH /**/ +#ifdef HAS_CSH +#define CSH "" /**/ +#endif + +/* HAS_CTERMID_R: + * This symbol, if defined, indicates that the ctermid_r routine + * is available to ctermid re-entrantly. + */ +/* CTERMID_R_PROTO: + * This symbol encodes the prototype of ctermid_r. + * It is zero if d_ctermid_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctermid_r + * is defined. + */ +/*#define HAS_CTERMID_R /**/ +#define CTERMID_R_PROTO 0 /**/ + +/* HAS_CTIME_R: + * This symbol, if defined, indicates that the ctime_r routine + * is available to ctime re-entrantly. + */ +/* CTIME_R_PROTO: + * This symbol encodes the prototype of ctime_r. + * It is zero if d_ctime_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ctime_r + * is defined. + */ +/*#define HAS_CTIME_R /**/ +#define CTIME_R_PROTO 0 /**/ + +/* HAS_DRAND48_R: + * This symbol, if defined, indicates that the drand48_r routine + * is available to drand48 re-entrantly. + */ +/* DRAND48_R_PROTO: + * This symbol encodes the prototype of drand48_r. + * It is zero if d_drand48_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_drand48_r + * is defined. + */ +/*#define HAS_DRAND48_R /**/ +#define DRAND48_R_PROTO 0 /**/ + +/* HAS_DRAND48_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the drand48() function. Otherwise, it is up + * to the program to supply one. A good guess is + * extern double drand48(void); + */ +/*#define HAS_DRAND48_PROTO /**/ + +/* HAS_EACCESS: + * This symbol, if defined, indicates that the eaccess routine is + * available to do extended access checks. + */ +/*#define HAS_EACCESS /**/ + +/* HAS_ENDGRENT: + * This symbol, if defined, indicates that the getgrent routine is + * available for finalizing sequential access of the group database. + */ +/*#define HAS_ENDGRENT /**/ + +/* HAS_ENDGRENT_R: + * This symbol, if defined, indicates that the endgrent_r routine + * is available to endgrent re-entrantly. + */ +/* ENDGRENT_R_PROTO: + * This symbol encodes the prototype of endgrent_r. + * It is zero if d_endgrent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r + * is defined. + */ +/*#define HAS_ENDGRENT_R /**/ +#define ENDGRENT_R_PROTO 0 /**/ + +/* HAS_ENDHOSTENT: + * This symbol, if defined, indicates that the endhostent() routine is + * available to close whatever was being used for host queries. + */ +/*#define HAS_ENDHOSTENT /**/ + +/* HAS_ENDHOSTENT_R: + * This symbol, if defined, indicates that the endhostent_r routine + * is available to endhostent re-entrantly. + */ +/* ENDHOSTENT_R_PROTO: + * This symbol encodes the prototype of endhostent_r. + * It is zero if d_endhostent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endhostent_r + * is defined. + */ +/*#define HAS_ENDHOSTENT_R /**/ +#define ENDHOSTENT_R_PROTO 0 /**/ + +/* HAS_ENDNETENT: + * This symbol, if defined, indicates that the endnetent() routine is + * available to close whatever was being used for network queries. + */ +/*#define HAS_ENDNETENT /**/ + +/* HAS_ENDNETENT_R: + * This symbol, if defined, indicates that the endnetent_r routine + * is available to endnetent re-entrantly. + */ +/* ENDNETENT_R_PROTO: + * This symbol encodes the prototype of endnetent_r. + * It is zero if d_endnetent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endnetent_r + * is defined. + */ +/*#define HAS_ENDNETENT_R /**/ +#define ENDNETENT_R_PROTO 0 /**/ + +/* HAS_ENDPROTOENT: + * This symbol, if defined, indicates that the endprotoent() routine is + * available to close whatever was being used for protocol queries. + */ +/*#define HAS_ENDPROTOENT /**/ + +/* HAS_ENDPROTOENT_R: + * This symbol, if defined, indicates that the endprotoent_r routine + * is available to endprotoent re-entrantly. + */ +/* ENDPROTOENT_R_PROTO: + * This symbol encodes the prototype of endprotoent_r. + * It is zero if d_endprotoent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endprotoent_r + * is defined. + */ +/*#define HAS_ENDPROTOENT_R /**/ +#define ENDPROTOENT_R_PROTO 0 /**/ + +/* HAS_ENDPWENT: + * This symbol, if defined, indicates that the getgrent routine is + * available for finalizing sequential access of the passwd database. + */ +/*#define HAS_ENDPWENT /**/ + +/* HAS_ENDPWENT_R: + * This symbol, if defined, indicates that the endpwent_r routine + * is available to endpwent re-entrantly. + */ +/* ENDPWENT_R_PROTO: + * This symbol encodes the prototype of endpwent_r. + * It is zero if d_endpwent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endpwent_r + * is defined. + */ +/*#define HAS_ENDPWENT_R /**/ +#define ENDPWENT_R_PROTO 0 /**/ + +/* HAS_ENDSERVENT: + * This symbol, if defined, indicates that the endservent() routine is + * available to close whatever was being used for service queries. + */ +/*#define HAS_ENDSERVENT /**/ + +/* HAS_ENDSERVENT_R: + * This symbol, if defined, indicates that the endservent_r routine + * is available to endservent re-entrantly. + */ +/* ENDSERVENT_R_PROTO: + * This symbol encodes the prototype of endservent_r. + * It is zero if d_endservent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_endservent_r + * is defined. + */ +/*#define HAS_ENDSERVENT_R /**/ +#define ENDSERVENT_R_PROTO 0 /**/ + +/* FLEXFILENAMES: + * This symbol, if defined, indicates that the system supports filenames + * longer than 14 characters. + */ +#define FLEXFILENAMES /**/ + +/* HAS_GETGRENT: + * This symbol, if defined, indicates that the getgrent routine is + * available for sequential access of the group database. + */ +/*#define HAS_GETGRENT /**/ + +/* HAS_GETGRENT_R: + * This symbol, if defined, indicates that the getgrent_r routine + * is available to getgrent re-entrantly. + */ +/* GETGRENT_R_PROTO: + * This symbol encodes the prototype of getgrent_r. + * It is zero if d_getgrent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrent_r + * is defined. + */ +/*#define HAS_GETGRENT_R /**/ +#define GETGRENT_R_PROTO 0 /**/ + +/* HAS_GETGRGID_R: + * This symbol, if defined, indicates that the getgrgid_r routine + * is available to getgrgid re-entrantly. + */ +/* GETGRGID_R_PROTO: + * This symbol encodes the prototype of getgrgid_r. + * It is zero if d_getgrgid_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrgid_r + * is defined. + */ +/*#define HAS_GETGRGID_R /**/ +#define GETGRGID_R_PROTO 0 /**/ + +/* HAS_GETGRNAM_R: + * This symbol, if defined, indicates that the getgrnam_r routine + * is available to getgrnam re-entrantly. + */ +/* GETGRNAM_R_PROTO: + * This symbol encodes the prototype of getgrnam_r. + * It is zero if d_getgrnam_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getgrnam_r + * is defined. + */ +/*#define HAS_GETGRNAM_R /**/ +#define GETGRNAM_R_PROTO 0 /**/ + +/* HAS_GETHOSTBYADDR: + * This symbol, if defined, indicates that the gethostbyaddr() routine is + * available to look up hosts by their IP addresses. + */ +#define HAS_GETHOSTBYADDR /**/ + +/* HAS_GETHOSTBYNAME: + * This symbol, if defined, indicates that the gethostbyname() routine is + * available to look up host names in some data base or other. + */ +#define HAS_GETHOSTBYNAME /**/ + +/* HAS_GETHOSTENT: + * This symbol, if defined, indicates that the gethostent() routine is + * available to look up host names in some data base or another. + */ +/*#define HAS_GETHOSTENT /**/ + +/* HAS_GETHOSTNAME: + * This symbol, if defined, indicates that the C program may use the + * gethostname() routine to derive the host name. See also HAS_UNAME + * and PHOSTNAME. + */ +/* HAS_UNAME: + * This symbol, if defined, indicates that the C program may use the + * uname() routine to derive the host name. See also HAS_GETHOSTNAME + * and PHOSTNAME. + */ +/* PHOSTNAME: + * This symbol, if defined, indicates the command to feed to the + * popen() routine to derive the host name. See also HAS_GETHOSTNAME + * and HAS_UNAME. Note that the command uses a fully qualified path, + * so that it is safe even if used by a process with super-user + * privileges. + */ +/* HAS_PHOSTNAME: + * This symbol, if defined, indicates that the C program may use the + * contents of PHOSTNAME as a command to feed to the popen() routine + * to derive the host name. + */ +#define HAS_GETHOSTNAME /**/ +#define HAS_UNAME /**/ +/*#define HAS_PHOSTNAME /**/ +#ifdef HAS_PHOSTNAME +#define PHOSTNAME "" /* How to get the host name */ +#endif + +/* HAS_GETHOSTBYADDR_R: + * This symbol, if defined, indicates that the gethostbyaddr_r routine + * is available to gethostbyaddr re-entrantly. + */ +/* GETHOSTBYADDR_R_PROTO: + * This symbol encodes the prototype of gethostbyaddr_r. + * It is zero if d_gethostbyaddr_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyaddr_r + * is defined. + */ +/*#define HAS_GETHOSTBYADDR_R /**/ +#define GETHOSTBYADDR_R_PROTO 0 /**/ + +/* HAS_GETHOSTBYNAME_R: + * This symbol, if defined, indicates that the gethostbyname_r routine + * is available to gethostbyname re-entrantly. + */ +/* GETHOSTBYNAME_R_PROTO: + * This symbol encodes the prototype of gethostbyname_r. + * It is zero if d_gethostbyname_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostbyname_r + * is defined. + */ +/*#define HAS_GETHOSTBYNAME_R /**/ +#define GETHOSTBYNAME_R_PROTO 0 /**/ + +/* HAS_GETHOSTENT_R: + * This symbol, if defined, indicates that the gethostent_r routine + * is available to gethostent re-entrantly. + */ +/* GETHOSTENT_R_PROTO: + * This symbol encodes the prototype of gethostent_r. + * It is zero if d_gethostent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gethostent_r + * is defined. + */ +/*#define HAS_GETHOSTENT_R /**/ +#define GETHOSTENT_R_PROTO 0 /**/ + +/* HAS_GETHOST_PROTOS: + * This symbol, if defined, indicates that <netdb.h> includes + * prototypes for gethostent(), gethostbyname(), and + * gethostbyaddr(). Otherwise, it is up to the program to guess + * them. See netdbtype.U for probing for various Netdb_xxx_t types. + */ +#define HAS_GETHOST_PROTOS /**/ + +/* HAS_GETLOGIN_R: + * This symbol, if defined, indicates that the getlogin_r routine + * is available to getlogin re-entrantly. + */ +/* GETLOGIN_R_PROTO: + * This symbol encodes the prototype of getlogin_r. + * It is zero if d_getlogin_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getlogin_r + * is defined. + */ +/*#define HAS_GETLOGIN_R /**/ +#define GETLOGIN_R_PROTO 0 /**/ + +/* HAS_GETNETBYADDR: + * This symbol, if defined, indicates that the getnetbyaddr() routine is + * available to look up networks by their IP addresses. + */ +/*#define HAS_GETNETBYADDR /**/ + +/* HAS_GETNETBYNAME: + * This symbol, if defined, indicates that the getnetbyname() routine is + * available to look up networks by their names. + */ +/*#define HAS_GETNETBYNAME /**/ + +/* HAS_GETNETENT: + * This symbol, if defined, indicates that the getnetent() routine is + * available to look up network names in some data base or another. + */ +/*#define HAS_GETNETENT /**/ + +/* HAS_GETNETBYADDR_R: + * This symbol, if defined, indicates that the getnetbyaddr_r routine + * is available to getnetbyaddr re-entrantly. + */ +/* GETNETBYADDR_R_PROTO: + * This symbol encodes the prototype of getnetbyaddr_r. + * It is zero if d_getnetbyaddr_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyaddr_r + * is defined. + */ +/*#define HAS_GETNETBYADDR_R /**/ +#define GETNETBYADDR_R_PROTO 0 /**/ + +/* HAS_GETNETBYNAME_R: + * This symbol, if defined, indicates that the getnetbyname_r routine + * is available to getnetbyname re-entrantly. + */ +/* GETNETBYNAME_R_PROTO: + * This symbol encodes the prototype of getnetbyname_r. + * It is zero if d_getnetbyname_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetbyname_r + * is defined. + */ +/*#define HAS_GETNETBYNAME_R /**/ +#define GETNETBYNAME_R_PROTO 0 /**/ + +/* HAS_GETNETENT_R: + * This symbol, if defined, indicates that the getnetent_r routine + * is available to getnetent re-entrantly. + */ +/* GETNETENT_R_PROTO: + * This symbol encodes the prototype of getnetent_r. + * It is zero if d_getnetent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getnetent_r + * is defined. + */ +/*#define HAS_GETNETENT_R /**/ +#define GETNETENT_R_PROTO 0 /**/ + +/* HAS_GETNET_PROTOS: + * This symbol, if defined, indicates that <netdb.h> includes + * prototypes for getnetent(), getnetbyname(), and + * getnetbyaddr(). Otherwise, it is up to the program to guess + * them. See netdbtype.U for probing for various Netdb_xxx_t types. + */ +/*#define HAS_GETNET_PROTOS /**/ + +/* HAS_GETPROTOENT: + * This symbol, if defined, indicates that the getprotoent() routine is + * available to look up protocols in some data base or another. + */ +/*#define HAS_GETPROTOENT /**/ + +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +/*#define HAS_GETPGRP /**/ +/*#define USE_BSD_GETPGRP /**/ + +/* HAS_GETPROTOBYNAME: + * This symbol, if defined, indicates that the getprotobyname() + * routine is available to look up protocols by their name. + */ +/* HAS_GETPROTOBYNUMBER: + * This symbol, if defined, indicates that the getprotobynumber() + * routine is available to look up protocols by their number. + */ +#define HAS_GETPROTOBYNAME /**/ +#define HAS_GETPROTOBYNUMBER /**/ + +/* HAS_GETPROTOBYNAME_R: + * This symbol, if defined, indicates that the getprotobyname_r routine + * is available to getprotobyname re-entrantly. + */ +/* GETPROTOBYNAME_R_PROTO: + * This symbol encodes the prototype of getprotobyname_r. + * It is zero if d_getprotobyname_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobyname_r + * is defined. + */ +/*#define HAS_GETPROTOBYNAME_R /**/ +#define GETPROTOBYNAME_R_PROTO 0 /**/ + +/* HAS_GETPROTOBYNUMBER_R: + * This symbol, if defined, indicates that the getprotobynumber_r routine + * is available to getprotobynumber re-entrantly. + */ +/* GETPROTOBYNUMBER_R_PROTO: + * This symbol encodes the prototype of getprotobynumber_r. + * It is zero if d_getprotobynumber_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotobynumber_r + * is defined. + */ +/*#define HAS_GETPROTOBYNUMBER_R /**/ +#define GETPROTOBYNUMBER_R_PROTO 0 /**/ + +/* HAS_GETPROTOENT_R: + * This symbol, if defined, indicates that the getprotoent_r routine + * is available to getprotoent re-entrantly. + */ +/* GETPROTOENT_R_PROTO: + * This symbol encodes the prototype of getprotoent_r. + * It is zero if d_getprotoent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getprotoent_r + * is defined. + */ +/*#define HAS_GETPROTOENT_R /**/ +#define GETPROTOENT_R_PROTO 0 /**/ + +/* HAS_GETPROTO_PROTOS: + * This symbol, if defined, indicates that <netdb.h> includes + * prototypes for getprotoent(), getprotobyname(), and + * getprotobyaddr(). Otherwise, it is up to the program to guess + * them. See netdbtype.U for probing for various Netdb_xxx_t types. + */ +#define HAS_GETPROTO_PROTOS /**/ + +/* HAS_GETPWENT: + * This symbol, if defined, indicates that the getpwent routine is + * available for sequential access of the passwd database. + * If this is not available, the older getpw() function may be available. + */ +/*#define HAS_GETPWENT /**/ + +/* HAS_GETPWENT_R: + * This symbol, if defined, indicates that the getpwent_r routine + * is available to getpwent re-entrantly. + */ +/* GETPWENT_R_PROTO: + * This symbol encodes the prototype of getpwent_r. + * It is zero if d_getpwent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwent_r + * is defined. + */ +/*#define HAS_GETPWENT_R /**/ +#define GETPWENT_R_PROTO 0 /**/ + +/* HAS_GETPWNAM_R: + * This symbol, if defined, indicates that the getpwnam_r routine + * is available to getpwnam re-entrantly. + */ +/* GETPWNAM_R_PROTO: + * This symbol encodes the prototype of getpwnam_r. + * It is zero if d_getpwnam_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwnam_r + * is defined. + */ +/*#define HAS_GETPWNAM_R /**/ +#define GETPWNAM_R_PROTO 0 /**/ + +/* HAS_GETPWUID_R: + * This symbol, if defined, indicates that the getpwuid_r routine + * is available to getpwuid re-entrantly. + */ +/* GETPWUID_R_PROTO: + * This symbol encodes the prototype of getpwuid_r. + * It is zero if d_getpwuid_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getpwuid_r + * is defined. + */ +/*#define HAS_GETPWUID_R /**/ +#define GETPWUID_R_PROTO 0 /**/ + +/* HAS_GETSERVENT: + * This symbol, if defined, indicates that the getservent() routine is + * available to look up network services in some data base or another. + */ +/*#define HAS_GETSERVENT /**/ + +/* HAS_GETSERVBYNAME_R: + * This symbol, if defined, indicates that the getservbyname_r routine + * is available to getservbyname re-entrantly. + */ +/* GETSERVBYNAME_R_PROTO: + * This symbol encodes the prototype of getservbyname_r. + * It is zero if d_getservbyname_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyname_r + * is defined. + */ +/*#define HAS_GETSERVBYNAME_R /**/ +#define GETSERVBYNAME_R_PROTO 0 /**/ + +/* HAS_GETSERVBYPORT_R: + * This symbol, if defined, indicates that the getservbyport_r routine + * is available to getservbyport re-entrantly. + */ +/* GETSERVBYPORT_R_PROTO: + * This symbol encodes the prototype of getservbyport_r. + * It is zero if d_getservbyport_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservbyport_r + * is defined. + */ +/*#define HAS_GETSERVBYPORT_R /**/ +#define GETSERVBYPORT_R_PROTO 0 /**/ + +/* HAS_GETSERVENT_R: + * This symbol, if defined, indicates that the getservent_r routine + * is available to getservent re-entrantly. + */ +/* GETSERVENT_R_PROTO: + * This symbol encodes the prototype of getservent_r. + * It is zero if d_getservent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getservent_r + * is defined. + */ +/*#define HAS_GETSERVENT_R /**/ +#define GETSERVENT_R_PROTO 0 /**/ + +/* HAS_GETSERV_PROTOS: + * This symbol, if defined, indicates that <netdb.h> includes + * prototypes for getservent(), getservbyname(), and + * getservbyaddr(). Otherwise, it is up to the program to guess + * them. See netdbtype.U for probing for various Netdb_xxx_t types. + */ +#define HAS_GETSERV_PROTOS /**/ + +/* HAS_GETSPNAM_R: + * This symbol, if defined, indicates that the getspnam_r routine + * is available to getspnam re-entrantly. + */ +/* GETSPNAM_R_PROTO: + * This symbol encodes the prototype of getspnam_r. + * It is zero if d_getspnam_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_getspnam_r + * is defined. + */ +/*#define HAS_GETSPNAM_R /**/ +#define GETSPNAM_R_PROTO 0 /**/ + +/* HAS_GETSERVBYNAME: + * This symbol, if defined, indicates that the getservbyname() + * routine is available to look up services by their name. + */ +/* HAS_GETSERVBYPORT: + * This symbol, if defined, indicates that the getservbyport() + * routine is available to look up services by their port. + */ +#define HAS_GETSERVBYNAME /**/ +#define HAS_GETSERVBYPORT /**/ + +/* HAS_GMTIME_R: + * This symbol, if defined, indicates that the gmtime_r routine + * is available to gmtime re-entrantly. + */ +/* GMTIME_R_PROTO: + * This symbol encodes the prototype of gmtime_r. + * It is zero if d_gmtime_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_gmtime_r + * is defined. + */ +/*#define HAS_GMTIME_R /**/ +#define GMTIME_R_PROTO 0 /**/ + +/* HAS_HTONL: + * This symbol, if defined, indicates that the htonl() routine (and + * friends htons() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_HTONS: + * This symbol, if defined, indicates that the htons() routine (and + * friends htonl() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHL: + * This symbol, if defined, indicates that the ntohl() routine (and + * friends htonl() htons() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHS: + * This symbol, if defined, indicates that the ntohs() routine (and + * friends htonl() htons() ntohl()) are available to do network + * order byte swapping. + */ +#define HAS_HTONL /**/ +#define HAS_HTONS /**/ +#define HAS_NTOHL /**/ +#define HAS_NTOHS /**/ + +/* HAS_LOCALTIME_R: + * This symbol, if defined, indicates that the localtime_r routine + * is available to localtime re-entrantly. + */ +/* LOCALTIME_R_NEEDS_TZSET: + * Many libc's localtime_r implementations do not call tzset, + * making them differ from localtime(), and making timezone + * changes using \undef{TZ} without explicitly calling tzset + * impossible. This symbol makes us call tzset before localtime_r + */ +/*#define LOCALTIME_R_NEEDS_TZSET /**/ +#ifdef LOCALTIME_R_NEEDS_TZSET +#define L_R_TZSET tzset(), +#else +#define L_R_TZSET +#endif + +/* LOCALTIME_R_PROTO: + * This symbol encodes the prototype of localtime_r. + * It is zero if d_localtime_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_localtime_r + * is defined. + */ +/*#define HAS_LOCALTIME_R /**/ +#define LOCALTIME_R_PROTO 0 /**/ + +/* HAS_LONG_DOUBLE: + * This symbol will be defined if the C compiler supports long + * doubles. + */ +/* LONG_DOUBLESIZE: + * This symbol contains the size of a long double, so that the + * C preprocessor can make decisions based on it. It is only + * defined if the system supports long doubles. + */ +#define HAS_LONG_DOUBLE /**/ +#ifdef HAS_LONG_DOUBLE +# ifdef _MSC_VER +# define LONG_DOUBLESIZE 8 /**/ +# else +# define LONG_DOUBLESIZE 12 /**/ +# endif +#endif + +/* HAS_LONG_LONG: + * This symbol will be defined if the C compiler supports long long. + */ +/* LONGLONGSIZE: + * This symbol contains the size of a long long, so that the + * C preprocessor can make decisions based on it. It is only + * defined if the system supports long long. + */ +#ifdef __GNUC__ +# define HAS_LONG_LONG /**/ +#endif +#ifdef HAS_LONG_LONG +#define LONGLONGSIZE 8 /**/ +#endif + +/* HAS_LSEEK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the lseek() function. Otherwise, it is up + * to the program to supply one. A good guess is + * extern off_t lseek(int, off_t, int); + */ +#define HAS_LSEEK_PROTO /**/ + +/* HAS_MEMCHR: + * This symbol, if defined, indicates that the memchr routine is available + * to locate characters within a C string. + */ +#define HAS_MEMCHR /**/ + +/* HAS_MKSTEMP: + * This symbol, if defined, indicates that the mkstemp routine is + * available to exclusively create and open a uniquely named + * temporary file. + */ +/*#define HAS_MKSTEMP /**/ + +/* HAS_MMAP: + * This symbol, if defined, indicates that the mmap system call is + * available to map a file into memory. + */ +/* Mmap_t: + * This symbol holds the return type of the mmap() system call + * (and simultaneously the type of the first argument). + * Usually set to 'void *' or 'caddr_t'. + */ +/*#define HAS_MMAP /**/ +#define Mmap_t void * /**/ + +/* HAS_MSG: + * This symbol, if defined, indicates that the entire msg*(2) library is + * supported (IPC mechanism based on message queues). + */ +/*#define HAS_MSG /**/ + +/* OLD_PTHREAD_CREATE_JOINABLE: + * This symbol, if defined, indicates how to create pthread + * in joinable (aka undetached) state. NOTE: not defined + * if pthread.h already has defined PTHREAD_CREATE_JOINABLE + * (the new version of the constant). + * If defined, known values are PTHREAD_CREATE_UNDETACHED + * and __UNDETACHED. + */ +/*#define OLD_PTHREAD_CREATE_JOINABLE /**/ + +/* HAS_PTHREAD_ATFORK: + * This symbol, if defined, indicates that the pthread_atfork routine + * is available to setup fork handlers. + */ +/*#define HAS_PTHREAD_ATFORK /**/ + +/* HAS_PTHREAD_YIELD: + * This symbol, if defined, indicates that the pthread_yield + * routine is available to yield the execution of the current + * thread. sched_yield is preferable to pthread_yield. + */ +/* SCHED_YIELD: + * This symbol defines the way to yield the execution of + * the current thread. Known ways are sched_yield, + * pthread_yield, and pthread_yield with NULL. + */ +/* HAS_SCHED_YIELD: + * This symbol, if defined, indicates that the sched_yield + * routine is available to yield the execution of the current + * thread. sched_yield is preferable to pthread_yield. + */ +/*#define HAS_PTHREAD_YIELD /**/ +#define SCHED_YIELD /**/ +/*#define HAS_SCHED_YIELD /**/ + +/* HAS_RANDOM_R: + * This symbol, if defined, indicates that the random_r routine + * is available to random re-entrantly. + */ +/* RANDOM_R_PROTO: + * This symbol encodes the prototype of random_r. + * It is zero if d_random_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_random_r + * is defined. + */ +/*#define HAS_RANDOM_R /**/ +#define RANDOM_R_PROTO 0 /**/ + +/* HAS_READDIR64_R: + * This symbol, if defined, indicates that the readdir64_r routine + * is available to readdir64 re-entrantly. + */ +/* READDIR64_R_PROTO: + * This symbol encodes the prototype of readdir64_r. + * It is zero if d_readdir64_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir64_r + * is defined. + */ +/*#define HAS_READDIR64_R /**/ +#define READDIR64_R_PROTO 0 /**/ + +/* HAS_READDIR_R: + * This symbol, if defined, indicates that the readdir_r routine + * is available to readdir re-entrantly. + */ +/* READDIR_R_PROTO: + * This symbol encodes the prototype of readdir_r. + * It is zero if d_readdir_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_readdir_r + * is defined. + */ +/*#define HAS_READDIR_R /**/ +#define READDIR_R_PROTO 0 /**/ + +/* HAS_SEM: + * This symbol, if defined, indicates that the entire sem*(2) library is + * supported. + */ +/*#define HAS_SEM /**/ + +/* HAS_SETGRENT: + * This symbol, if defined, indicates that the setgrent routine is + * available for initializing sequential access of the group database. + */ +/*#define HAS_SETGRENT /**/ + +/* HAS_SETGRENT_R: + * This symbol, if defined, indicates that the setgrent_r routine + * is available to setgrent re-entrantly. + */ +/* SETGRENT_R_PROTO: + * This symbol encodes the prototype of setgrent_r. + * It is zero if d_setgrent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setgrent_r + * is defined. + */ +/*#define HAS_SETGRENT_R /**/ +#define SETGRENT_R_PROTO 0 /**/ + +/* HAS_SETHOSTENT: + * This symbol, if defined, indicates that the sethostent() routine is + * available. + */ +/*#define HAS_SETHOSTENT /**/ + +/* HAS_SETHOSTENT_R: + * This symbol, if defined, indicates that the sethostent_r routine + * is available to sethostent re-entrantly. + */ +/* SETHOSTENT_R_PROTO: + * This symbol encodes the prototype of sethostent_r. + * It is zero if d_sethostent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_sethostent_r + * is defined. + */ +/*#define HAS_SETHOSTENT_R /**/ +#define SETHOSTENT_R_PROTO 0 /**/ + +/* HAS_SETLOCALE_R: + * This symbol, if defined, indicates that the setlocale_r routine + * is available to setlocale re-entrantly. + */ +/* SETLOCALE_R_PROTO: + * This symbol encodes the prototype of setlocale_r. + * It is zero if d_setlocale_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setlocale_r + * is defined. + */ +/*#define HAS_SETLOCALE_R /**/ +#define SETLOCALE_R_PROTO 0 /**/ + +/* HAS_SETNETENT: + * This symbol, if defined, indicates that the setnetent() routine is + * available. + */ +/*#define HAS_SETNETENT /**/ + +/* HAS_SETNETENT_R: + * This symbol, if defined, indicates that the setnetent_r routine + * is available to setnetent re-entrantly. + */ +/* SETNETENT_R_PROTO: + * This symbol encodes the prototype of setnetent_r. + * It is zero if d_setnetent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setnetent_r + * is defined. + */ +/*#define HAS_SETNETENT_R /**/ +#define SETNETENT_R_PROTO 0 /**/ + +/* HAS_SETPROTOENT: + * This symbol, if defined, indicates that the setprotoent() routine is + * available. + */ +/*#define HAS_SETPROTOENT /**/ + +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +/*#define HAS_SETPGRP /**/ +/*#define USE_BSD_SETPGRP /**/ + +/* HAS_SETPROTOENT_R: + * This symbol, if defined, indicates that the setprotoent_r routine + * is available to setprotoent re-entrantly. + */ +/* SETPROTOENT_R_PROTO: + * This symbol encodes the prototype of setprotoent_r. + * It is zero if d_setprotoent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setprotoent_r + * is defined. + */ +/*#define HAS_SETPROTOENT_R /**/ +#define SETPROTOENT_R_PROTO 0 /**/ + +/* HAS_SETPWENT: + * This symbol, if defined, indicates that the setpwent routine is + * available for initializing sequential access of the passwd database. + */ +/*#define HAS_SETPWENT /**/ + +/* HAS_SETPWENT_R: + * This symbol, if defined, indicates that the setpwent_r routine + * is available to setpwent re-entrantly. + */ +/* SETPWENT_R_PROTO: + * This symbol encodes the prototype of setpwent_r. + * It is zero if d_setpwent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setpwent_r + * is defined. + */ +/*#define HAS_SETPWENT_R /**/ +#define SETPWENT_R_PROTO 0 /**/ + +/* HAS_SETSERVENT: + * This symbol, if defined, indicates that the setservent() routine is + * available. + */ +/*#define HAS_SETSERVENT /**/ + +/* HAS_SETSERVENT_R: + * This symbol, if defined, indicates that the setservent_r routine + * is available to setservent re-entrantly. + */ +/* SETSERVENT_R_PROTO: + * This symbol encodes the prototype of setservent_r. + * It is zero if d_setservent_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_setservent_r + * is defined. + */ +/*#define HAS_SETSERVENT_R /**/ +#define SETSERVENT_R_PROTO 0 /**/ + +/* HAS_SETVBUF: + * This symbol, if defined, indicates that the setvbuf routine is + * available to change buffering on an open stdio stream. + * to a line-buffered mode. + */ +#define HAS_SETVBUF /**/ + +/* HAS_SHM: + * This symbol, if defined, indicates that the entire shm*(2) library is + * supported. + */ +/*#define HAS_SHM /**/ + +/* Shmat_t: + * This symbol holds the return type of the shmat() system call. + * Usually set to 'void *' or 'char *'. + */ +/* HAS_SHMAT_PROTOTYPE: + * This symbol, if defined, indicates that the sys/shm.h includes + * a prototype for shmat(). Otherwise, it is up to the program to + * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess, + * but not always right so it should be emitted by the program only + * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. + */ +#define Shmat_t void * /**/ +/*#define HAS_SHMAT_PROTOTYPE /**/ + +/* HAS_SOCKET: + * This symbol, if defined, indicates that the BSD socket interface is + * supported. + */ +/* HAS_SOCKETPAIR: + * This symbol, if defined, indicates that the BSD socketpair() call is + * supported. + */ +/* HAS_MSG_CTRUNC: + * This symbol, if defined, indicates that the MSG_CTRUNC is supported. + * Checking just with #ifdef might not be enough because this symbol + * has been known to be an enum. + */ +/* HAS_MSG_DONTROUTE: + * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. + * Checking just with #ifdef might not be enough because this symbol + * has been known to be an enum. + */ +/* HAS_MSG_OOB: + * This symbol, if defined, indicates that the MSG_OOB is supported. + * Checking just with #ifdef might not be enough because this symbol + * has been known to be an enum. + */ +/* HAS_MSG_PEEK: + * This symbol, if defined, indicates that the MSG_PEEK is supported. + * Checking just with #ifdef might not be enough because this symbol + * has been known to be an enum. + */ +/* HAS_MSG_PROXY: + * This symbol, if defined, indicates that the MSG_PROXY is supported. + * Checking just with #ifdef might not be enough because this symbol + * has been known to be an enum. + */ +/* HAS_SCM_RIGHTS: + * This symbol, if defined, indicates that the SCM_RIGHTS is supported. + * Checking just with #ifdef might not be enough because this symbol + * has been known to be an enum. + */ +#define HAS_SOCKET /**/ +/*#define HAS_SOCKETPAIR /**/ +/*#define HAS_MSG_CTRUNC /**/ +/*#define HAS_MSG_DONTROUTE /**/ +/*#define HAS_MSG_OOB /**/ +/*#define HAS_MSG_PEEK /**/ +/*#define HAS_MSG_PROXY /**/ +/*#define HAS_SCM_RIGHTS /**/ + +/* HAS_SRAND48_R: + * This symbol, if defined, indicates that the srand48_r routine + * is available to srand48 re-entrantly. + */ +/* SRAND48_R_PROTO: + * This symbol encodes the prototype of srand48_r. + * It is zero if d_srand48_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srand48_r + * is defined. + */ +/*#define HAS_SRAND48_R /**/ +#define SRAND48_R_PROTO 0 /**/ + +/* HAS_SRANDOM_R: + * This symbol, if defined, indicates that the srandom_r routine + * is available to srandom re-entrantly. + */ +/* SRANDOM_R_PROTO: + * This symbol encodes the prototype of srandom_r. + * It is zero if d_srandom_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_srandom_r + * is defined. + */ +/*#define HAS_SRANDOM_R /**/ +#define SRANDOM_R_PROTO 0 /**/ + +/* USE_STAT_BLOCKS: + * This symbol is defined if this system has a stat structure declaring + * st_blksize and st_blocks. + */ +#ifndef USE_STAT_BLOCKS +/*#define USE_STAT_BLOCKS /**/ +#endif + +/* USE_STRUCT_COPY: + * This symbol, if defined, indicates that this C compiler knows how + * to copy structures. If undefined, you'll need to use a block copy + * routine of some sort instead. + */ +#define USE_STRUCT_COPY /**/ + +/* HAS_STRERROR: + * This symbol, if defined, indicates that the strerror routine is + * available to translate error numbers to strings. See the writeup + * of Strerror() in this file before you try to define your own. + */ +/* HAS_SYS_ERRLIST: + * This symbol, if defined, indicates that the sys_errlist array is + * available to translate error numbers to strings. The extern int + * sys_nerr gives the size of that table. + */ +/* Strerror: + * This preprocessor symbol is defined as a macro if strerror() is + * not available to translate error numbers to strings but sys_errlist[] + * array is there. + */ +#define HAS_STRERROR /**/ +#define HAS_SYS_ERRLIST /**/ +#define Strerror(e) strerror(e) + +/* HAS_STRERROR_R: + * This symbol, if defined, indicates that the strerror_r routine + * is available to strerror re-entrantly. + */ +/* STRERROR_R_PROTO: + * This symbol encodes the prototype of strerror_r. + * It is zero if d_strerror_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_strerror_r + * is defined. + */ +/*#define HAS_STRERROR_R /**/ +#define STRERROR_R_PROTO 0 /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ + +/* HAS_TIME: + * This symbol, if defined, indicates that the time() routine exists. + */ +/* Time_t: + * This symbol holds the type returned by time(). It can be long, + * or time_t on BSD sites (in which case <sys/types.h> should be + * included). + */ +#define HAS_TIME /**/ +#define Time_t time_t /* Time type */ + +/* HAS_TIMES: + * This symbol, if defined, indicates that the times() routine exists. + * Note that this became obsolete on some systems (SUNOS), which now + * use getrusage(). It may be necessary to include <sys/times.h>. + */ +#define HAS_TIMES /**/ + +/* HAS_TMPNAM_R: + * This symbol, if defined, indicates that the tmpnam_r routine + * is available to tmpnam re-entrantly. + */ +/* TMPNAM_R_PROTO: + * This symbol encodes the prototype of tmpnam_r. + * It is zero if d_tmpnam_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_tmpnam_r + * is defined. + */ +/*#define HAS_TMPNAM_R /**/ +#define TMPNAM_R_PROTO 0 /**/ + +/* HAS_TTYNAME_R: + * This symbol, if defined, indicates that the ttyname_r routine + * is available to ttyname re-entrantly. + */ +/* TTYNAME_R_PROTO: + * This symbol encodes the prototype of ttyname_r. + * It is zero if d_ttyname_r is undef, and one of the + * REENTRANT_PROTO_T_ABC macros of reentr.h if d_ttyname_r + * is defined. + */ +/*#define HAS_TTYNAME_R /**/ +#define TTYNAME_R_PROTO 0 /**/ + +/* HAS_UNION_SEMUN: + * This symbol, if defined, indicates that the union semun is + * defined by including <sys/sem.h>. If not, the user code + * probably needs to define it as: + * union semun { + * int val; + * struct semid_ds *buf; + * unsigned short *array; + * } + */ +/* USE_SEMCTL_SEMUN: + * This symbol, if defined, indicates that union semun is + * used for semctl IPC_STAT. + */ +/* USE_SEMCTL_SEMID_DS: + * This symbol, if defined, indicates that struct semid_ds * is + * used for semctl IPC_STAT. + */ +#define HAS_UNION_SEMUN /**/ +/*#define USE_SEMCTL_SEMUN /**/ +/*#define USE_SEMCTL_SEMID_DS /**/ + +/* HAS_VFORK: + * This symbol, if defined, indicates that vfork() exists. + */ +/*#define HAS_VFORK /**/ + +/* HAS_PSEUDOFORK: + * This symbol, if defined, indicates that an emulation of the + * fork routine is available. + */ +/*#define HAS_PSEUDOFORK /**/ + +/* Signal_t: + * This symbol's value is either "void" or "int", corresponding to the + * appropriate return type of a signal handler. Thus, you can declare + * a signal handler using "Signal_t (*handler)()", and define the + * handler using "Signal_t handler(sig)". + */ +#define Signal_t void /* Signal handler's return type */ + +/* HASVOLATILE: + * This symbol, if defined, indicates that this C compiler knows about + * the volatile declaration. + */ +#define HASVOLATILE /**/ +#ifndef HASVOLATILE +#define volatile +#endif + +/* Fpos_t: + * This symbol holds the type used to declare file positions in libc. + * It can be fpos_t, long, uint, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Fpos_t fpos_t /* File position type */ + +/* Gid_t_f: + * This symbol defines the format string used for printing a Gid_t. + */ +#define Gid_t_f "ld" /**/ + +/* Gid_t_sign: + * This symbol holds the signedess of a Gid_t. + * 1 for unsigned, -1 for signed. + */ +#define Gid_t_sign -1 /* GID sign */ + +/* Gid_t_size: + * This symbol holds the size of a Gid_t in bytes. + */ +#define Gid_t_size 4 /* GID size */ + +/* Gid_t: + * This symbol holds the return type of getgid() and the type of + * argument to setrgid() and related functions. Typically, + * it is the type of group ids in the kernel. It can be int, ushort, + * gid_t, etc... It may be necessary to include <sys/types.h> to get + * any typedef'ed information. + */ +#define Gid_t gid_t /* Type for getgid(), etc... */ + +/* I_DIRENT: + * This symbol, if defined, indicates to the C program that it should + * include <dirent.h>. Using this symbol also triggers the definition + * of the Direntry_t define which ends up being 'struct dirent' or + * 'struct direct' depending on the availability of <dirent.h>. + */ +/* DIRNAMLEN: + * This symbol, if defined, indicates to the C program that the length + * of directory entry names is provided by a d_namlen field. Otherwise + * you need to do strlen() on the d_name field. + */ +/* Direntry_t: + * This symbol is set to 'struct direct' or 'struct dirent' depending on + * whether dirent is available or not. You should use this pseudo type to + * portably declare your directory entries. + */ +#define I_DIRENT /**/ +#define DIRNAMLEN /**/ +#define Direntry_t struct direct + +/* I_GRP: + * This symbol, if defined, indicates to the C program that it should + * include <grp.h>. + */ +/* GRPASSWD: + * This symbol, if defined, indicates to the C program that struct group + * in <grp.h> contains gr_passwd. + */ +/*#define I_GRP /**/ +/*#define GRPASSWD /**/ + +/* I_MACH_CTHREADS: + * This symbol, if defined, indicates to the C program that it should + * include <mach/cthreads.h>. + */ +/*#define I_MACH_CTHREADS /**/ + +/* I_NDBM: + * This symbol, if defined, indicates that <ndbm.h> exists and should + * be included. + */ +/* I_GDBMNDBM: + * This symbol, if defined, indicates that <gdbm/ndbm.h> exists and should + * be included. This was the location of the ndbm.h compatibility file + * in RedHat 7.1. + */ +/* I_GDBM_NDBM: + * This symbol, if defined, indicates that <gdbm-ndbm.h> exists and should + * be included. This is the location of the ndbm.h compatibility file + * in Debian 4.0. + */ +/* NDBM_H_USES_PROTOTYPES: + * This symbol, if defined, indicates that <ndbm.h> uses real ANSI C + * prototypes instead of K&R style function declarations without any + * parameter information. While ANSI C prototypes are supported in C++, + * K&R style function declarations will yield errors. + */ +/* GDBMNDBM_H_USES_PROTOTYPES: + * This symbol, if defined, indicates that <gdbm/ndbm.h> uses real ANSI C + * prototypes instead of K&R style function declarations without any + * parameter information. While ANSI C prototypes are supported in C++, + * K&R style function declarations will yield errors. + */ +/* GDBM_NDBM_H_USES_PROTOTYPES: + * This symbol, if defined, indicates that <gdbm-ndbm.h> uses real ANSI C + * prototypes instead of K&R style function declarations without any + * parameter information. While ANSI C prototypes are supported in C++, + * K&R style function declarations will yield errors. + */ +/*#define I_NDBM /**/ +/*#define I_GDBMNDBM /**/ +/*#define I_GDBM_NDBM /**/ +/*#define NDBM_H_USES_PROTOTYPES /**/ +/*#define GDBMNDBM_H_USES_PROTOTYPES /**/ +/*#define GDBM_NDBM_H_USES_PROTOTYPES /**/ + +/* I_NETDB: + * This symbol, if defined, indicates that <netdb.h> exists and + * should be included. + */ +/*#define I_NETDB /**/ + +/* I_NET_ERRNO: + * This symbol, if defined, indicates that <net/errno.h> exists and + * should be included. + */ +/*#define I_NET_ERRNO /**/ + +/* I_PTHREAD: + * This symbol, if defined, indicates to the C program that it should + * include <pthread.h>. + */ +/*#define I_PTHREAD /**/ + +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include <pwd.h>. + */ +/* PWQUOTA: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +/* PWCHANGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_change. + */ +/* PWCLASS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +/* PWGECOS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_gecos. + */ +/* PWPASSWD: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_passwd. + */ +/*#define I_PWD /**/ +/*#define PWQUOTA /**/ +/*#define PWAGE /**/ +/*#define PWCHANGE /**/ +/*#define PWCLASS /**/ +/*#define PWEXPIRE /**/ +/*#define PWCOMMENT /**/ +/*#define PWGECOS /**/ +/*#define PWPASSWD /**/ + +/* I_SYS_ACCESS: + * This symbol, if defined, indicates to the C program that it should + * include <sys/access.h>. + */ +/*#define I_SYS_ACCESS /**/ + +/* I_SYS_SECURITY: + * This symbol, if defined, indicates to the C program that it should + * include <sys/security.h>. + */ +/*#define I_SYS_SECURITY /**/ + +/* I_SYSUIO: + * This symbol, if defined, indicates that <sys/uio.h> exists and + * should be included. + */ +/*#define I_SYSUIO /**/ + +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ +/* I_VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include <varargs.h>. + */ +#define I_STDARG /**/ +/*#define I_VARARGS /**/ + +/* PERL_INC_VERSION_LIST: + * This variable specifies the list of subdirectories in over + * which perl.c:incpush() and lib/lib.pm will automatically + * search when adding directories to @INC, in a format suitable + * for a C initialization string. See the inc_version_list entry + * in Porting/Glossary for more details. + */ +/*#define PERL_INC_VERSION_LIST 0 /**/ + +/* INSTALL_USR_BIN_PERL: + * This symbol, if defined, indicates that Perl is to be installed + * also as /usr/bin/perl. + */ +/*#define INSTALL_USR_BIN_PERL /**/ + +/* Off_t: + * This symbol holds the type used to declare offsets in the kernel. + * It can be int, long, off_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +/* LSEEKSIZE: + * This symbol holds the number of bytes used by the Off_t. + */ +/* Off_t_size: + * This symbol holds the number of bytes used by the Off_t. + */ +#ifdef _MSC_VER +# define Off_t __int64 /* <offset> type */ +#else +# define Off_t long long /* <offset> type */ +#endif +#define LSEEKSIZE 8 /* <offset> size */ +#define Off_t_size 8 /* <offset> size */ + +/* Free_t: + * This variable contains the return type of free(). It is usually + * void, but occasionally int. + */ +/* Malloc_t: + * This symbol is the type of pointer returned by malloc and realloc. + */ +#define Malloc_t void * /**/ +#define Free_t void /**/ + +/* PERL_MALLOC_WRAP: + * This symbol, if defined, indicates that we'd like malloc wrap checks. + */ +#define PERL_MALLOC_WRAP /**/ + +/* MYMALLOC: + * This symbol, if defined, indicates that we're using our own malloc. + */ +/*#define MYMALLOC /**/ + +/* Mode_t: + * This symbol holds the type used to declare file modes + * for systems calls. It is usually mode_t, but may be + * int or unsigned short. It may be necessary to include <sys/types.h> + * to get any typedef'ed information. + */ +#define Mode_t mode_t /* file mode parameter for system calls */ + +/* Netdb_host_t: + * This symbol holds the type used for the 1st argument + * to gethostbyaddr(). + */ +/* Netdb_hlen_t: + * This symbol holds the type used for the 2nd argument + * to gethostbyaddr(). + */ +/* Netdb_name_t: + * This symbol holds the type used for the argument to + * gethostbyname(). + */ +/* Netdb_net_t: + * This symbol holds the type used for the 1st argument to + * getnetbyaddr(). + */ +#define Netdb_host_t char * /**/ +#define Netdb_hlen_t int /**/ +#define Netdb_name_t char * /**/ +#define Netdb_net_t long /**/ + +/* PERL_OTHERLIBDIRS: + * This variable contains a colon-separated set of paths for the perl + * binary to search for additional library files or modules. + * These directories will be tacked to the end of @INC. + * Perl will automatically search below each path for version- + * and architecture-specific directories. See PERL_INC_VERSION_LIST + * for more details. + */ +/*#define PERL_OTHERLIBDIRS "" /**/ + +/* Pid_t: + * This symbol holds the type used to declare process ids in the kernel. + * It can be int, uint, pid_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Pid_t int /* PID type */ + +/* PRIVLIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + */ +/* PRIVLIB_EXP: + * 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 "c:\\perl\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING)) /**/ + +/* CAN_PROTOTYPE: + * If defined, this macro indicates that the C compiler can handle + * function prototypes. + */ +/* _: + * This macro is used to declare function parameters for folks who want + * to make declarations with prototypes using a different style than + * the above macros. Use double parentheses. For example: + * + * int main _((int argc, char *argv[])); + */ +#define CAN_PROTOTYPE /**/ +#ifdef CAN_PROTOTYPE +#define _(args) args +#else +#define _(args) () +#endif + +/* Select_fd_set_t: + * This symbol holds the type used for the 2nd, 3rd, and 4th + * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET + * is defined, and 'int *' otherwise. This is only useful if you + * have select(), of course. + */ +#define Select_fd_set_t Perl_fd_set * /**/ + +/* SH_PATH: + * This symbol contains the full pathname to the shell used on this + * on this system to execute Bourne shell scripts. Usually, this will be + * /bin/sh, though it's possible that some systems will have /bin/ksh, + * /bin/pdksh, /bin/ash, /bin/bash, or even something such as + * D:/bin/sh.exe. + */ +#define SH_PATH "cmd /x /c" /**/ + +/* SIG_NAME: + * This symbol contains a list of signal names in order of + * signal number. This is intended + * to be used as a static array initialization, like this: + * char *sig_name[] = { SIG_NAME }; + * The signals in the list are separated with commas, and each signal + * is surrounded by double quotes. There is no leading SIG in the signal + * name, i.e. SIGQUIT is known as "QUIT". + * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, + * etc., where nn is the actual signal number (e.g. NUM37). + * The signal number for sig_name[i] is stored in sig_num[i]. + * The last element is 0 to terminate the list with a NULL. This + * corresponds to the 0 at the end of the sig_name_init list. + * Note that this variable is initialized from the sig_name_init, + * not from sig_name (which is unused). + */ +/* SIG_NUM: + * This symbol contains a list of signal numbers, in the same order as the + * SIG_NAME list. It is suitable for static array initialization, as in: + * int sig_num[] = { SIG_NUM }; + * The signals in the list are separated with commas, and the indices + * within that list and the SIG_NAME list match, so it's easy to compute + * the signal name from a number or vice versa at the price of a small + * dynamic linear lookup. + * Duplicates are allowed, but are moved to the end of the list. + * The signal number corresponding to sig_name[i] is sig_number[i]. + * if (i < NSIG) then sig_number[i] == i. + * The last element is 0, corresponding to the 0 at the end of + * the sig_name_init list. + * Note that this variable is initialized from the sig_num_init, + * not from sig_num (which is unused). + */ +/* SIG_SIZE: + * This variable contains the number of elements of the SIG_NAME + * and SIG_NUM arrays, excluding the final NULL entry. + */ +#define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0 /**/ +#define SIG_NUM 0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0 /**/ +#define SIG_SIZE 27 /**/ + +/* SITEARCH: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + * The standard distribution will put nothing in this directory. + * After perl has been installed, users may install their own local + * architecture-dependent modules in this directory with + * MakeMaker Makefile.PL + * or equivalent. See INSTALL for details. + */ +/* SITEARCH_EXP: + * 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\\lib" /**/ +/*#define SITEARCH_EXP "" /**/ + +/* SITELIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + * The standard distribution will put nothing in this directory. + * After perl has been installed, users may install their own local + * architecture-independent modules in this directory with + * MakeMaker Makefile.PL + * or equivalent. See INSTALL for details. + */ +/* SITELIB_EXP: + * This symbol contains the ~name expanded version of SITELIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +/* SITELIB_STEM: + * This define is SITELIB_EXP with any trailing version-specific component + * 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\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib(PERL_VERSION_STRING)) /**/ +#define SITELIB_STEM "" /**/ + +/* Size_t_size: + * This symbol holds the size of a Size_t in bytes. + */ +#define Size_t_size 8 /**/ + +/* Size_t: + * This symbol holds the type used to declare length parameters + * for string functions. It is usually size_t, but may be + * unsigned long, int, etc. It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Size_t size_t /* length paramater for string functions */ + +/* Sock_size_t: + * This symbol holds the type used for the size argument of + * various socket calls (just the base type, not the pointer-to). + */ +#define Sock_size_t int /**/ + +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR char /**/ + +/* Uid_t_f: + * This symbol defines the format string used for printing a Uid_t. + */ +#define Uid_t_f "ld" /**/ + +/* Uid_t_sign: + * This symbol holds the signedess of a Uid_t. + * 1 for unsigned, -1 for signed. + */ +#define Uid_t_sign -1 /* UID sign */ + +/* Uid_t_size: + * This symbol holds the size of a Uid_t in bytes. + */ +#define Uid_t_size 4 /* UID size */ + +/* Uid_t: + * This symbol holds the type used to declare user ids in the kernel. + * It can be int, ushort, uid_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Uid_t uid_t /* UID type */ + +/* USE_ITHREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the interpreter-based threading implementation. + */ +/* USE_5005THREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the 5.005-based threading implementation. + * Only valid up to 5.8.x. + */ +/* OLD_PTHREADS_API: + * This symbol, if defined, indicates that Perl should + * be built to use the old draft POSIX threads API. + */ +/* USE_REENTRANT_API: + * This symbol, if defined, indicates that Perl should + * try to use the various _r versions of library functions. + * This is extremely experimental. + */ +/*#define USE_5005THREADS /**/ +/*#define USE_ITHREADS /**/ +#if defined(USE_5005THREADS) && !defined(USE_ITHREADS) +#define USE_THREADS /* until src is revised*/ +#endif +/*#define OLD_PTHREADS_API /**/ +/*#define USE_REENTRANT_API /**/ + +/* PERL_VENDORARCH: + * If defined, this symbol contains the name of a private library. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. + * It may have a ~ on the front. + * The standard distribution will put nothing in this directory. + * Vendors who distribute perl may wish to place their own + * architecture-dependent modules and extensions in this directory with + * MakeMaker Makefile.PL INSTALLDIRS=vendor + * or equivalent. See INSTALL for details. + */ +/* PERL_VENDORARCH_EXP: + * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +/*#define PERL_VENDORARCH "" /**/ +/*#define PERL_VENDORARCH_EXP "" /**/ + +/* PERL_VENDORLIB_EXP: + * This symbol contains the ~name expanded version of VENDORLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +/* PERL_VENDORLIB_STEM: + * This define is PERL_VENDORLIB_EXP with any trailing version-specific component + * 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 PERL_VENDORLIB_EXP "" /**/ +/*#define PERL_VENDORLIB_STEM "" /**/ + +/* VOIDFLAGS: + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * 8 = suports declaration of generic void pointers + * + * The package designer should define VOIDUSED to indicate the requirements + * of the package. This can be done either by #defining VOIDUSED before + * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the + * level of void support necessary is not present, defines void to int. + */ +#ifndef VOIDUSED +#define VOIDUSED 15 +#endif +#define VOIDFLAGS 15 +#if (VOIDFLAGS & VOIDUSED) != VOIDUSED +#define void int /* is void to be avoided? */ +#define M_VOID /* Xenix strikes again */ +#endif + +/* USE_CROSS_COMPILE: + * This symbol, if defined, indicates that Perl is being cross-compiled. + */ +/* PERL_TARGETARCH: + * This symbol, if defined, indicates the target architecture + * Perl has been cross-compiled to. Undefined if not a cross-compile. + */ +#ifndef USE_CROSS_COMPILE +/*#define USE_CROSS_COMPILE /**/ +#define PERL_TARGETARCH "" /**/ +#endif + +/* MEM_ALIGNBYTES: + * This symbol contains the number of bytes required to align a + * double, or a long double when applicable. Usual values are 2, + * 4 and 8. The default is eight, for safety. + */ +#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) +# define MEM_ALIGNBYTES 8 +#else +#define MEM_ALIGNBYTES 8 +#endif + +/* BYTEORDER: + * This symbol holds the hexadecimal constant defined in byteorder, + * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... + * If the compiler supports cross-compiling or multiple-architecture + * binaries (eg. on NeXT systems), use compiler-defined macros to + * determine the byte order. + * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture + * Binaries (MAB) on either big endian or little endian machines. + * The endian-ness is available at compile-time. This only matters + * for perl, where the config.h can be generated and installed on + * one system, and used by a different architecture to build an + * extension. Older versions of NeXT that might not have + * defined either *_ENDIAN__ were all on Motorola 680x0 series, + * so the default case (for NeXT) is big endian to catch them. + * This might matter for NeXT 3.0. + */ +#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH) +# ifdef __LITTLE_ENDIAN__ +# if LONGSIZE == 4 +# define BYTEORDER 0x1234 +# else +# if LONGSIZE == 8 +# define BYTEORDER 0x12345678 +# endif +# endif +# else +# ifdef __BIG_ENDIAN__ +# if LONGSIZE == 4 +# define BYTEORDER 0x4321 +# else +# if LONGSIZE == 8 +# define BYTEORDER 0x87654321 +# endif +# endif +# endif +# endif +# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) +# define BYTEORDER 0x4321 +# endif +#else +#define BYTEORDER 0x1234 /* large digits for MSB */ +#endif /* NeXT */ + +/* CASTI32: + * This symbol is defined if the C compiler can cast negative + * or large floating point numbers to 32-bit ints. + */ +#ifndef _MSC_VER +# define CASTI32 /**/ +#endif + +/* CASTNEGFLOAT: + * This symbol is defined if the C compiler can cast negative + * numbers to unsigned longs, ints and shorts. + */ +/* CASTFLAGS: + * This symbol contains flags that say what difficulties the compiler + * has casting odd floating values to unsigned long: + * 0 = ok + * 1 = couldn't cast < 0 + * 2 = couldn't cast >= 0x80000000 + * 4 = couldn't cast in argument expression list + */ +#define CASTNEGFLOAT /**/ +#define CASTFLAGS 0 /**/ + +/* VOID_CLOSEDIR: + * This symbol, if defined, indicates that the closedir() routine + * does not return a value. + */ +/*#define VOID_CLOSEDIR /**/ + +/* HAS_FD_SET: + * This symbol, when defined, indicates presence of the fd_set typedef + * in <sys/types.h> + */ +#define HAS_FD_SET /**/ + +/* Gconvert: + * This preprocessor macro is defined to convert a floating point + * number to a string without a trailing decimal point. This + * emulates the behavior of sprintf("%g"), but is sometimes much more + * efficient. If gconvert() is not available, but gcvt() drops the + * trailing decimal point, then gcvt() is used. If all else fails, + * a macro using sprintf("%g") is used. Arguments for the Gconvert + * macro are: value, number of digits, whether trailing zeros should + * be retained, and the output buffer. + * The usual values are: + * d_Gconvert='gconvert((x),(n),(t),(b))' + * d_Gconvert='gcvt((x),(n),(b))' + * d_Gconvert='sprintf((b),"%.*g",(n),(x))' + * The last two assume trailing zeros should not be kept. + */ +#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) + +/* HAS_GETPAGESIZE: + * This symbol, if defined, indicates that the getpagesize system call + * is available to get system page size, which is the granularity of + * many memory management calls. + */ +/*#define HAS_GETPAGESIZE /**/ + +/* HAS_GNULIBC: + * This symbol, if defined, indicates to the C program that + * the GNU C library is being used. A better check is to use + * the __GLIBC__ and __GLIBC_MINOR__ symbols supplied with glibc. + */ +/*#define HAS_GNULIBC /**/ +#if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) +# define _GNU_SOURCE +#endif + +/* HAS_ISASCII: + * This manifest constant lets the C program know that isascii + * is available. + */ +#define HAS_ISASCII /**/ + +/* HAS_LCHOWN: + * This symbol, if defined, indicates that the lchown routine is + * available to operate on a symbolic link (instead of following the + * link). + */ +/*#define HAS_LCHOWN /**/ + +/* HAS_OPEN3: + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. + */ +/*#define HAS_OPEN3 /**/ + +/* HAS_SAFE_BCOPY: + * This symbol, if defined, indicates that the bcopy routine is available + * to copy potentially overlapping memory blocks. Normally, you should + * probably use memmove() or memcpy(). If neither is defined, roll your + * own version. + */ +/*#define HAS_SAFE_BCOPY /**/ + +/* HAS_SAFE_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy potentially overlapping memory blocks. If you need to + * copy overlapping memory blocks, you should check HAS_MEMMOVE and + * use memmove() instead, if available. + */ +/*#define HAS_SAFE_MEMCPY /**/ + +/* HAS_SANE_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * and can be used to compare relative magnitudes of chars with their high + * bits set. If it is not defined, roll your own version. + */ +#define HAS_SANE_MEMCMP /**/ + +/* HAS_SIGACTION: + * This symbol, if defined, indicates that Vr4's sigaction() routine + * is available. + */ +/*#define HAS_SIGACTION /**/ + +/* HAS_SIGSETJMP: + * This variable indicates to the C program that the sigsetjmp() + * routine is available to save the calling process's registers + * and stack environment for later use by siglongjmp(), and + * to optionally save the process's signal mask. See + * Sigjmp_buf, Sigsetjmp, and Siglongjmp. + */ +/* Sigjmp_buf: + * This is the buffer type to be used with Sigsetjmp and Siglongjmp. + */ +/* Sigsetjmp: + * This macro is used in the same way as sigsetjmp(), but will invoke + * traditional setjmp() if sigsetjmp isn't available. + * See HAS_SIGSETJMP. + */ +/* Siglongjmp: + * This macro is used in the same way as siglongjmp(), but will invoke + * traditional longjmp() if siglongjmp isn't available. + * See HAS_SIGSETJMP. + */ +/*#define HAS_SIGSETJMP /**/ +#ifdef HAS_SIGSETJMP +#define Sigjmp_buf sigjmp_buf +#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) +#define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) +#else +#define Sigjmp_buf jmp_buf +#define Sigsetjmp(buf,save_mask) setjmp((buf)) +#define Siglongjmp(buf,retval) longjmp((buf),(retval)) +#endif + +/* USE_STDIO_PTR: + * This symbol is defined if the _ptr and _cnt fields (or similar) + * of the stdio FILE structure can be used to access the stdio buffer + * for a file handle. If this is defined, then the FILE_ptr(fp) + * and FILE_cnt(fp) macros will also be defined and should be used + * to access these fields. + */ +/* FILE_ptr: + * This macro is used to access the _ptr field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_PTR is defined. + */ +/* STDIO_PTR_LVALUE: + * This symbol is defined if the FILE_ptr macro can be used as an + * lvalue. + */ +/* FILE_cnt: + * This macro is used to access the _cnt field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_PTR is defined. + */ +/* STDIO_CNT_LVALUE: + * This symbol is defined if the FILE_cnt macro can be used as an + * lvalue. + */ +/* STDIO_PTR_LVAL_SETS_CNT: + * This symbol is defined if using the FILE_ptr macro as an lvalue + * to increase the pointer by n has the side effect of decreasing the + * value of File_cnt(fp) by n. + */ +/* STDIO_PTR_LVAL_NOCHANGE_CNT: + * This symbol is defined if using the FILE_ptr macro as an lvalue + * to increase the pointer by n leaves File_cnt(fp) unchanged. + */ +#define USE_STDIO_PTR /**/ +#ifdef USE_STDIO_PTR +#define FILE_ptr(fp) ((fp)->_ptr) +#define STDIO_PTR_LVALUE /**/ +#define FILE_cnt(fp) ((fp)->_cnt) +#define STDIO_CNT_LVALUE /**/ +/*#define STDIO_PTR_LVAL_SETS_CNT /**/ +#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/ +#endif + +/* USE_STDIO_BASE: + * This symbol is defined if the _base field (or similar) of the + * stdio FILE structure can be used to access the stdio buffer for + * a file handle. If this is defined, then the FILE_base(fp) macro + * will also be defined and should be used to access this field. + * Also, the FILE_bufsiz(fp) macro will be defined and should be used + * to determine the number of bytes in the buffer. USE_STDIO_BASE + * will never be defined unless USE_STDIO_PTR is. + */ +/* FILE_base: + * This macro is used to access the _base field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_BASE is defined. + */ +/* FILE_bufsiz: + * This macro is used to determine the number of bytes in the I/O + * buffer pointed to by _base field (or equivalent) of the FILE + * structure pointed to its argument. This macro will always be defined + * if USE_STDIO_BASE is defined. + */ +#define USE_STDIO_BASE /**/ +#ifdef USE_STDIO_BASE +#define FILE_base(fp) ((fp)->_base) +#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) +#endif + +/* HAS_VPRINTF: + * This symbol, if defined, indicates that the vprintf routine is available + * to printf with a pointer to an argument list. If unavailable, you + * may need to write your own, probably in terms of _doprnt(). + */ +/* USE_CHAR_VSPRINTF: + * This symbol is defined if this system has vsprintf() returning type + * (char*). The trend seems to be to declare it as "int vsprintf()". It + * is up to the package author to declare vsprintf correctly based on the + * symbol. + */ +#define HAS_VPRINTF /**/ +/*#define USE_CHAR_VSPRINTF /**/ + +/* DOUBLESIZE: + * This symbol contains the size of a double, so that the C preprocessor + * can make decisions based on it. + */ +#define DOUBLESIZE 8 /**/ + +/* I_TIME: + * This symbol, if defined, indicates to the C program that it should + * include <time.h>. + */ +/* I_SYS_TIME: + * This symbol, if defined, indicates to the C program that it should + * include <sys/time.h>. + */ +/* I_SYS_TIME_KERNEL: + * This symbol, if defined, indicates to the C program that it should + * include <sys/time.h> with KERNEL defined. + */ +/* HAS_TM_TM_ZONE: + * This symbol, if defined, indicates to the C program that + * the struct tm has a tm_zone field. + */ +/* HAS_TM_TM_GMTOFF: + * This symbol, if defined, indicates to the C program that + * the struct tm has a tm_gmtoff field. + */ +#define I_TIME /**/ +/*#define I_SYS_TIME /**/ +/*#define I_SYS_TIME_KERNEL /**/ +/*#define HAS_TM_TM_ZONE /**/ +/*#define HAS_TM_TM_GMTOFF /**/ + +/* VAL_O_NONBLOCK: + * This symbol is to be used during open() or fcntl(F_SETFL) to turn on + * non-blocking I/O for the file descriptor. Note that there is no way + * back, i.e. you cannot turn it blocking again this way. If you wish to + * alternatively switch between blocking and non-blocking, use the + * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. + */ +/* VAL_EAGAIN: + * This symbol holds the errno error code set by read() when no data was + * present on the non-blocking file descriptor. + */ +/* RD_NODATA: + * This symbol holds the return code from read() when no data is present + * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is + * not defined, then you can't distinguish between no data and EOF by + * issuing a read(). You'll have to find another way to tell for sure! + */ +/* EOF_NONBLOCK: + * This symbol, if defined, indicates to the C program that a read() on + * a non-blocking file descriptor will return 0 on EOF, and not the value + * held in RD_NODATA (-1 usually, in that case!). + */ +#define VAL_O_NONBLOCK O_NONBLOCK +#define VAL_EAGAIN EAGAIN +#define RD_NODATA -1 +#define EOF_NONBLOCK + +/* PTRSIZE: + * This symbol contains the size of a pointer, so that the C preprocessor + * can make decisions based on it. It will be sizeof(void *) if + * the compiler supports (void *); otherwise it will be + * sizeof(char *). + */ +#define PTRSIZE 8 /**/ + +/* Drand01: + * This macro is to be used to generate uniformly distributed + * random numbers over the range [0., 1.[. You may have to supply + * an 'extern double drand48();' in your program since SunOS 4.1.3 + * doesn't provide you with anything relevant in its headers. + * See HAS_DRAND48_PROTO. + */ +/* Rand_seed_t: + * This symbol defines the type of the argument of the + * random seed function. + */ +/* seedDrand01: + * This symbol defines the macro to be used in seeding the + * random number generator (see Drand01). + */ +/* RANDBITS: + * This symbol indicates how many bits are produced by the + * function used to generate normalized random numbers. + * Values include 15, 16, 31, and 48. + */ +#define Drand01() (rand()/(double)((unsigned)1<<RANDBITS)) /**/ +#define Rand_seed_t unsigned /**/ +#define seedDrand01(x) srand((Rand_seed_t)x) /**/ +#define RANDBITS 15 /**/ + +/* SSize_t: + * This symbol holds the type used by functions that return + * a count of bytes or an error condition. It must be a signed type. + * It is usually ssize_t, but may be long or int, etc. + * It may be necessary to include <sys/types.h> or <unistd.h> + * to get any typedef'ed information. + * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). + */ +#ifdef _MSC_VER +# define SSize_t __int64 /* signed count of bytes */ +#else +# define SSize_t long long /* signed count of bytes */ +#endif + +/* EBCDIC: + * This symbol, if defined, indicates that this system uses + * EBCDIC encoding. + */ +/*#define EBCDIC /**/ + +/* SETUID_SCRIPTS_ARE_SECURE_NOW: + * This symbol, if defined, indicates that the bug that prevents + * setuid scripts from being secure is not present in this kernel. + */ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +/*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +/*#define DOSUID /**/ + +/* PERL_USE_DEVEL: + * This symbol, if defined, indicates that Perl was configured with + * -Dusedevel, to enable development features. This should not be + * done for production builds. + */ +/*#define PERL_USE_DEVEL /**/ + +/* HAS_ATOLF: + * This symbol, if defined, indicates that the atolf routine is + * available to convert strings into long doubles. + */ +/*#define HAS_ATOLF /**/ + +/* HAS_ATOLL: + * This symbol, if defined, indicates that the atoll routine is + * available to convert strings into long longs. + */ +#define HAS_ATOLL /**/ + +/* HAS__FWALK: + * This symbol, if defined, indicates that the _fwalk system call is + * available to apply a function to all the file handles. + */ +/*#define HAS__FWALK /**/ + +/* HAS_AINTL: + * This symbol, if defined, indicates that the aintl routine is + * available. If copysignl is also present we can emulate modfl. + */ +/*#define HAS_AINTL /**/ + +/* HAS_BUILTIN_CHOOSE_EXPR: + * Can we handle GCC builtin for compile-time ternary-like expressions + */ +/* HAS_BUILTIN_EXPECT: + * Can we handle GCC builtin for telling that certain values are more + * likely + */ +/*#define HAS_BUILTIN_EXPECT /**/ +/*#define HAS_BUILTIN_CHOOSE_EXPR /**/ + +/* HAS_C99_VARIADIC_MACROS: + * If defined, the compiler supports C99 variadic macros. + */ +/*#define HAS_C99_VARIADIC_MACROS /**/ + +/* HAS_CLASS: + * This symbol, if defined, indicates that the class routine is + * available to classify doubles. Available for example in AIX. + * The returned values are defined in <float.h> and are: + * + * FP_PLUS_NORM Positive normalized, nonzero + * FP_MINUS_NORM Negative normalized, nonzero + * FP_PLUS_DENORM Positive denormalized, nonzero + * FP_MINUS_DENORM Negative denormalized, nonzero + * FP_PLUS_ZERO +0.0 + * FP_MINUS_ZERO -0.0 + * FP_PLUS_INF +INF + * FP_MINUS_INF -INF + * FP_NANS Signaling Not a Number (NaNS) + * FP_NANQ Quiet Not a Number (NaNQ) + */ +/*#define HAS_CLASS /**/ + +/* HAS_CLEARENV: + * This symbol, if defined, indicates that the clearenv () routine is + * available for use. + */ +/*#define HAS_CLEARENV /**/ + +/* HAS_STRUCT_CMSGHDR: + * This symbol, if defined, indicates that the struct cmsghdr + * is supported. + */ +/*#define HAS_STRUCT_CMSGHDR /**/ + +/* HAS_COPYSIGNL: + * This symbol, if defined, indicates that the copysignl routine is + * available. If aintl is also present we can emulate modfl. + */ +/*#define HAS_COPYSIGNL /**/ + +/* USE_CPLUSPLUS: + * This symbol, if defined, indicates that a C++ compiler was + * used to compiled Perl and will be used to compile extensions. + */ +/*#define USE_CPLUSPLUS /**/ + +/* HAS_DBMINIT_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the dbminit() function. Otherwise, it is up + * to the program to supply one. A good guess is + * extern int dbminit(char *); + */ +/*#define HAS_DBMINIT_PROTO /**/ + +/* HAS_DIR_DD_FD: + * This symbol, if defined, indicates that the the DIR* dirstream + * structure contains a member variable named dd_fd. + */ +/*#define HAS_DIR_DD_FD /**/ + +/* HAS_DIRFD: + * This manifest constant lets the C program know that dirfd + * is available. + */ +/*#define HAS_DIRFD /**/ + +/* DLSYM_NEEDS_UNDERSCORE: + * This symbol, if defined, indicates that we need to prepend an + * underscore to the symbol name before calling dlsym(). This only + * makes sense if you *have* dlsym, which we will presume is the + * case if you're using dl_dlopen.xs. + */ +/*#define DLSYM_NEEDS_UNDERSCORE /**/ + +/* HAS_FAST_STDIO: + * This symbol, if defined, indicates that the "fast stdio" + * is available to manipulate the stdio buffers directly. + */ +#define HAS_FAST_STDIO /**/ + +/* HAS_FCHDIR: + * This symbol, if defined, indicates that the fchdir routine is + * available to change directory using a file descriptor. + */ +/*#define HAS_FCHDIR /**/ + +/* FCNTL_CAN_LOCK: + * This symbol, if defined, indicates that fcntl() can be used + * for file locking. Normally on Unix systems this is defined. + * It may be undefined on VMS. + */ +/*#define FCNTL_CAN_LOCK /**/ + +/* HAS_FINITE: + * This symbol, if defined, indicates that the finite routine is + * available to check whether a double is finite (non-infinity non-NaN). + */ +/*#define HAS_FINITE /**/ + +/* HAS_FINITEL: + * This symbol, if defined, indicates that the finitel routine is + * available to check whether a long double is finite + * (non-infinity non-NaN). + */ +/*#define HAS_FINITEL /**/ + +/* HAS_FLOCK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the flock() function. Otherwise, it is up + * to the program to supply one. A good guess is + * extern int flock(int, int); + */ +#define HAS_FLOCK_PROTO /**/ + +/* HAS_FP_CLASS: + * This symbol, if defined, indicates that the fp_class routine is + * available to classify doubles. Available for example in Digital UNIX. + * The returned values are defined in <math.h> and are: + * + * FP_SNAN Signaling NaN (Not-a-Number) + * FP_QNAN Quiet NaN (Not-a-Number) + * FP_POS_INF +infinity + * FP_NEG_INF -infinity + * FP_POS_NORM Positive normalized + * FP_NEG_NORM Negative normalized + * FP_POS_DENORM Positive denormalized + * FP_NEG_DENORM Negative denormalized + * FP_POS_ZERO +0.0 (positive zero) + * FP_NEG_ZERO -0.0 (negative zero) + */ +/*#define HAS_FP_CLASS /**/ + +/* HAS_FPCLASS: + * This symbol, if defined, indicates that the fpclass routine is + * available to classify doubles. Available for example in Solaris/SVR4. + * The returned values are defined in <ieeefp.h> and are: + * + * FP_SNAN signaling NaN + * FP_QNAN quiet NaN + * FP_NINF negative infinity + * FP_PINF positive infinity + * FP_NDENORM negative denormalized non-zero + * FP_PDENORM positive denormalized non-zero + * FP_NZERO negative zero + * FP_PZERO positive zero + * FP_NNORM negative normalized non-zero + * FP_PNORM positive normalized non-zero + */ +/*#define HAS_FPCLASS /**/ + +/* HAS_FPCLASSIFY: + * This symbol, if defined, indicates that the fpclassify routine is + * available to classify doubles. Available for example in HP-UX. + * The returned values are defined in <math.h> and are + * + * FP_NORMAL Normalized + * FP_ZERO Zero + * FP_INFINITE Infinity + * FP_SUBNORMAL Denormalized + * FP_NAN NaN + * + */ +/*#define HAS_FPCLASSIFY /**/ + +/* HAS_FPCLASSL: + * This symbol, if defined, indicates that the fpclassl routine is + * available to classify long doubles. Available for example in IRIX. + * The returned values are defined in <ieeefp.h> and are: + * + * FP_SNAN signaling NaN + * FP_QNAN quiet NaN + * FP_NINF negative infinity + * FP_PINF positive infinity + * FP_NDENORM negative denormalized non-zero + * FP_PDENORM positive denormalized non-zero + * FP_NZERO negative zero + * FP_PZERO positive zero + * FP_NNORM negative normalized non-zero + * FP_PNORM positive normalized non-zero + */ +/*#define HAS_FPCLASSL /**/ + +/* HAS_FPOS64_T: + * This symbol will be defined if the C compiler supports fpos64_t. + */ +/*#define HAS_FPOS64_T /**/ + +/* HAS_FREXPL: + * This symbol, if defined, indicates that the frexpl routine is + * available to break a long double floating-point number into + * a normalized fraction and an integral power of 2. + */ +/*#define HAS_FREXPL /**/ + +/* HAS_STRUCT_FS_DATA: + * This symbol, if defined, indicates that the struct fs_data + * to do statfs() is supported. + */ +/*#define HAS_STRUCT_FS_DATA /**/ + +/* HAS_FSEEKO: + * This symbol, if defined, indicates that the fseeko routine is + * available to fseek beyond 32 bits (useful for ILP32 hosts). + */ +/*#define HAS_FSEEKO /**/ + +/* HAS_FSTATFS: + * This symbol, if defined, indicates that the fstatfs routine is + * available to stat filesystems by file descriptors. + */ +/*#define HAS_FSTATFS /**/ + +/* HAS_FSYNC: + * This symbol, if defined, indicates that the fsync routine is + * available to write a file's modified data and attributes to + * permanent storage. + */ +/*#define HAS_FSYNC /**/ + +/* HAS_FTELLO: + * This symbol, if defined, indicates that the ftello routine is + * available to ftell beyond 32 bits (useful for ILP32 hosts). + */ +/*#define HAS_FTELLO /**/ + +/* HAS_FUTIMES: + * This symbol, if defined, indicates that the futimes routine is + * available to change file descriptor time stamps with struct timevals. + */ +/*#define HAS_FUTIMES /**/ + +/* HAS_GETADDRINFO: + * This symbol, if defined, indicates that the getaddrinfo() function + * is available for use. + */ +/*#define HAS_GETADDRINFO /**/ + +/* HAS_GETCWD: + * This symbol, if defined, indicates that the getcwd routine is + * available to get the current working directory. + */ +#define HAS_GETCWD /**/ + +/* HAS_GETESPWNAM: + * This symbol, if defined, indicates that the getespwnam system call is + * available to retrieve enchanced (shadow) password entries by name. + */ +/*#define HAS_GETESPWNAM /**/ + +/* HAS_GETFSSTAT: + * This symbol, if defined, indicates that the getfsstat routine is + * available to stat filesystems in bulk. + */ +/*#define HAS_GETFSSTAT /**/ + +/* HAS_GETITIMER: + * This symbol, if defined, indicates that the getitimer routine is + * available to return interval timers. + */ +/*#define HAS_GETITIMER /**/ + +/* HAS_GETMNT: + * This symbol, if defined, indicates that the getmnt routine is + * available to get filesystem mount info by filename. + */ +/*#define HAS_GETMNT /**/ + +/* HAS_GETMNTENT: + * This symbol, if defined, indicates that the getmntent routine is + * available to iterate through mounted file systems to get their info. + */ +/*#define HAS_GETMNTENT /**/ + +/* HAS_GETNAMEINFO: + * This symbol, if defined, indicates that the getnameinfo() function + * is available for use. + */ +/*#define HAS_GETNAMEINFO /**/ + +/* HAS_GETPRPWNAM: + * This symbol, if defined, indicates that the getprpwnam system call is + * available to retrieve protected (shadow) password entries by name. + */ +/*#define HAS_GETPRPWNAM /**/ + +/* HAS_GETSPNAM: + * This symbol, if defined, indicates that the getspnam system call is + * available to retrieve SysV shadow password entries by name. + */ +/*#define HAS_GETSPNAM /**/ + +/* HAS_HASMNTOPT: + * This symbol, if defined, indicates that the hasmntopt routine is + * available to query the mount options of file systems. + */ +/*#define HAS_HASMNTOPT /**/ + +/* HAS_ILOGBL: + * This symbol, if defined, indicates that the ilogbl routine is + * available. If scalbnl is also present we can emulate frexpl. + */ +/*#define HAS_ILOGBL /**/ + +/* HAS_INETNTOP: + * This symbol, if defined, indicates that the inet_ntop() function + * is available to parse IPv4 and IPv6 strings. + */ +/*#define HAS_INETNTOP /**/ + +/* HAS_INETPTON: + * This symbol, if defined, indicates that the inet_pton() function + * is available to parse IPv4 and IPv6 strings. + */ +/*#define HAS_INETPTON /**/ + +/* HAS_INT64_T: + * This symbol will defined if the C compiler supports int64_t. + * Usually the <inttypes.h> needs to be included, but sometimes + * <sys/types.h> is enough. + */ +/*#define HAS_INT64_T /**/ + +/* HAS_ISFINITE: + * This symbol, if defined, indicates that the isfinite routine is + * available to check whether a double is finite (non-infinity non-NaN). + */ +/*#define HAS_ISFINITE /**/ + +/* HAS_ISINF: + * This symbol, if defined, indicates that the isinf routine is + * available to check whether a double is an infinity. + */ +/*#define HAS_ISINF /**/ + +/* HAS_ISNAN: + * This symbol, if defined, indicates that the isnan routine is + * available to check whether a double is a NaN. + */ +#define HAS_ISNAN /**/ + +/* HAS_ISNANL: + * This symbol, if defined, indicates that the isnanl routine is + * available to check whether a long double is a NaN. + */ +/*#define HAS_ISNANL /**/ + +/* HAS_LDBL_DIG: + * This symbol, if defined, indicates that this system's <float.h> + * or <limits.h> defines the symbol LDBL_DIG, which is the number + * of significant digits in a long double precision number. Unlike + * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined. + */ +#define HAS_LDBL_DIG /**/ + +/* LIBM_LIB_VERSION: + * This symbol, if defined, indicates that libm exports _LIB_VERSION + * and that math.h defines the enum to manipulate it. + */ +/*#define LIBM_LIB_VERSION /**/ + +/* HAS_MADVISE: + * This symbol, if defined, indicates that the madvise system call is + * available to map a file into memory. + */ +/*#define HAS_MADVISE /**/ + +/* HAS_MALLOC_SIZE: + * This symbol, if defined, indicates that the malloc_size + * routine is available for use. + */ +/*#define HAS_MALLOC_SIZE /**/ + +/* HAS_MALLOC_GOOD_SIZE: + * This symbol, if defined, indicates that the malloc_good_size + * routine is available for use. + */ +/*#define HAS_MALLOC_GOOD_SIZE /**/ + +/* HAS_MKDTEMP: + * This symbol, if defined, indicates that the mkdtemp routine is + * available to exclusively create a uniquely named temporary directory. + */ +/*#define HAS_MKDTEMP /**/ + +/* HAS_MKSTEMPS: + * This symbol, if defined, indicates that the mkstemps routine is + * available to excluslvely create and open a uniquely named + * (with a suffix) temporary file. + */ +/*#define HAS_MKSTEMPS /**/ + +/* HAS_MODFL: + * This symbol, if defined, indicates that the modfl routine is + * available to split a long double x into a fractional part f and + * an integer part i such that |f| < 1.0 and (f + i) = x. + */ +/* HAS_MODFL_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the modfl() function. Otherwise, it is up + * to the program to supply one. + */ +/* HAS_MODFL_POW32_BUG: + * This symbol, if defined, indicates that the modfl routine is + * broken for long doubles >= pow(2, 32). + * For example from 4294967303.150000 one would get 4294967302.000000 + * and 1.150000. The bug has been seen in certain versions of glibc, + * release 2.2.2 is known to be okay. + */ +/*#define HAS_MODFL /**/ +/*#define HAS_MODFL_PROTO /**/ +/*#define HAS_MODFL_POW32_BUG /**/ + +/* HAS_MPROTECT: + * This symbol, if defined, indicates that the mprotect system call is + * available to modify the access protection of a memory mapped file. + */ +/*#define HAS_MPROTECT /**/ + +/* HAS_STRUCT_MSGHDR: + * This symbol, if defined, indicates that the struct msghdr + * is supported. + */ +/*#define HAS_STRUCT_MSGHDR /**/ + +/* HAS_NL_LANGINFO: + * This symbol, if defined, indicates that the nl_langinfo routine is + * available to return local data. You will also need <langinfo.h> + * and therefore I_LANGINFO. + */ +/*#define HAS_NL_LANGINFO /**/ + +/* HAS_OFF64_T: + * This symbol will be defined if the C compiler supports off64_t. + */ +/*#define HAS_OFF64_T /**/ + +/* HAS_PROCSELFEXE: + * This symbol is defined if PROCSELFEXE_PATH is a symlink + * to the absolute pathname of the executing program. + */ +/* PROCSELFEXE_PATH: + * If HAS_PROCSELFEXE is defined this symbol is the filename + * of the symbolic link pointing to the absolute pathname of + * the executing program. + */ +/*#define HAS_PROCSELFEXE /**/ +#if defined(HAS_PROCSELFEXE) && !defined(PROCSELFEXE_PATH) +#define PROCSELFEXE_PATH /**/ +#endif + +/* HAS_PTHREAD_ATTR_SETSCOPE: + * This symbol, if defined, indicates that the pthread_attr_setscope + * system call is available to set the contention scope attribute of + * a thread attribute object. + */ +/*#define HAS_PTHREAD_ATTR_SETSCOPE /**/ + +/* HAS_READV: + * This symbol, if defined, indicates that the readv routine is + * available to do gather reads. You will also need <sys/uio.h> + * and there I_SYSUIO. + */ +/*#define HAS_READV /**/ + +/* HAS_RECVMSG: + * This symbol, if defined, indicates that the recvmsg routine is + * available to send structured socket messages. + */ +/*#define HAS_RECVMSG /**/ + +/* HAS_SBRK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sbrk() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern void* sbrk(int); + * extern void* sbrk(size_t); + */ +/*#define HAS_SBRK_PROTO /**/ + +/* HAS_SCALBNL: + * This symbol, if defined, indicates that the scalbnl routine is + * available. If ilogbl is also present we can emulate frexpl. + */ +/*#define HAS_SCALBNL /**/ + +/* HAS_SENDMSG: + * This symbol, if defined, indicates that the sendmsg routine is + * available to send structured socket messages. + */ +/*#define HAS_SENDMSG /**/ + +/* HAS_SETITIMER: + * This symbol, if defined, indicates that the setitimer routine is + * available to set interval timers. + */ +/*#define HAS_SETITIMER /**/ + +/* HAS_SETPROCTITLE: + * This symbol, if defined, indicates that the setproctitle routine is + * available to set process title. + */ +/*#define HAS_SETPROCTITLE /**/ + +/* USE_SFIO: + * This symbol, if defined, indicates that sfio should + * be used. + */ +/*#define USE_SFIO /**/ + +/* HAS_SIGNBIT: + * This symbol, if defined, indicates that the signbit routine is + * available to check if the given number has the sign bit set. + * This should include correct testing of -0.0. This will only be set + * if the signbit() routine is safe to use with the NV type used internally + * in perl. Users should call Perl_signbit(), which will be #defined to + * the system's signbit() function or macro if this symbol is defined. + */ +/*#define HAS_SIGNBIT /**/ + +/* HAS_SIGPROCMASK: + * This symbol, if defined, indicates that the sigprocmask + * system call is available to examine or change the signal mask + * of the calling process. + */ +/*#define HAS_SIGPROCMASK /**/ + +/* USE_SITECUSTOMIZE: + * This symbol, if defined, indicates that sitecustomize should + * be used. + */ +#ifndef USE_SITECUSTOMIZE +/*#define USE_SITECUSTOMIZE /**/ +#endif + +/* HAS_SNPRINTF: + * This symbol, if defined, indicates that the snprintf () library + * function is available for use. + */ +/* HAS_VSNPRINTF: + * This symbol, if defined, indicates that the vsnprintf () library + * function is available for use. + */ +#define HAS_SNPRINTF /**/ +#define HAS_VSNPRINTF /**/ + +/* HAS_SOCKATMARK: + * This symbol, if defined, indicates that the sockatmark routine is + * available to test whether a socket is at the out-of-band mark. + */ +/*#define HAS_SOCKATMARK /**/ + +/* HAS_SOCKATMARK_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the sockatmark() function. Otherwise, it is up + * to the program to supply one. A good guess is + * extern int sockatmark(int); + */ +/*#define HAS_SOCKATMARK_PROTO /**/ + +/* HAS_SOCKS5_INIT: + * This symbol, if defined, indicates that the socks5_init routine is + * available to initialize SOCKS 5. + */ +/*#define HAS_SOCKS5_INIT /**/ + +/* SPRINTF_RETURNS_STRLEN: + * This variable defines whether sprintf returns the length of the string + * (as per the ANSI spec). Some C libraries retain compatibility with + * pre-ANSI C and return a pointer to the passed in buffer; for these + * this variable will be undef. + */ +#define SPRINTF_RETURNS_STRLEN /**/ + +/* HAS_SQRTL: + * This symbol, if defined, indicates that the sqrtl routine is + * available to do long double square roots. + */ +/*#define HAS_SQRTL /**/ + +/* HAS_SETRESGID_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the setresgid() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid); + */ +/*#define HAS_SETRESGID_PROTO /**/ + +/* HAS_SETRESUID_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the setresuid() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid); + */ +/*#define HAS_SETRESUID_PROTO /**/ + +/* HAS_STRUCT_STATFS_F_FLAGS: + * This symbol, if defined, indicates that the struct statfs + * does have the f_flags member containing the mount flags of + * the filesystem containing the file. + * This kind of struct statfs is coming from <sys/mount.h> (BSD 4.3), + * not from <sys/statfs.h> (SYSV). Older BSDs (like Ultrix) do not + * have statfs() and struct statfs, they have ustat() and getmnt() + * with struct ustat and struct fs_data. + */ +/*#define HAS_STRUCT_STATFS_F_FLAGS /**/ + +/* HAS_STRUCT_STATFS: + * This symbol, if defined, indicates that the struct statfs + * to do statfs() is supported. + */ +/*#define HAS_STRUCT_STATFS /**/ + +/* HAS_FSTATVFS: + * This symbol, if defined, indicates that the fstatvfs routine is + * available to stat filesystems by file descriptors. + */ +/*#define HAS_FSTATVFS /**/ + +/* HAS_STRFTIME: + * This symbol, if defined, indicates that the strftime routine is + * available to do time formatting. + */ +#define HAS_STRFTIME /**/ + +/* HAS_STRLCAT: + * This symbol, if defined, indicates that the strlcat () routine is + * available to do string concatenation. + */ +/*#define HAS_STRLCAT /**/ + +/* HAS_STRLCPY: + * This symbol, if defined, indicates that the strlcpy () routine is + * available to do string copying. + */ +/*#define HAS_STRLCPY /**/ + +/* HAS_STRTOLD: + * This symbol, if defined, indicates that the strtold routine is + * available to convert strings to long doubles. + */ +/*#define HAS_STRTOLD /**/ + +/* HAS_STRTOLL: + * This symbol, if defined, indicates that the strtoll routine is + * available to convert strings to long longs. + */ +#define HAS_STRTOLL /**/ + +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +/*#define HAS_STRTOQ /**/ + +/* HAS_STRTOULL: + * This symbol, if defined, indicates that the strtoull routine is + * available to convert strings to unsigned long longs. + */ +#define HAS_STRTOULL /**/ + +/* HAS_STRTOUQ: + * This symbol, if defined, indicates that the strtouq routine is + * available to convert strings to unsigned long longs (quads). + */ +/*#define HAS_STRTOUQ /**/ + +/* HAS_SYSCALL_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the syscall() function. Otherwise, it is up + * to the program to supply one. Good guesses are + * extern int syscall(int, ...); + * extern int syscall(long, ...); + */ +/*#define HAS_SYSCALL_PROTO /**/ + +/* HAS_TELLDIR_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the telldir() function. Otherwise, it is up + * to the program to supply one. A good guess is + * extern long telldir(DIR*); + */ +#define HAS_TELLDIR_PROTO /**/ + +/* HAS_CTIME64: + * This symbol, if defined, indicates that the ctime64 () routine is + * available to do the 64bit variant of ctime () + */ +/* HAS_LOCALTIME64: + * This symbol, if defined, indicates that the localtime64 () routine is + * available to do the 64bit variant of localtime () + */ +/* HAS_GMTIME64: + * This symbol, if defined, indicates that the gmtime64 () routine is + * available to do the 64bit variant of gmtime () + */ +/* HAS_MKTIME64: + * This symbol, if defined, indicates that the mktime64 () routine is + * available to do the 64bit variant of mktime () + */ +/* HAS_DIFFTIME64: + * This symbol, if defined, indicates that the difftime64 () routine is + * available to do the 64bit variant of difftime () + */ +/* HAS_ASCTIME64: + * This symbol, if defined, indicates that the asctime64 () routine is + * available to do the 64bit variant of asctime () + */ +/*#define HAS_CTIME64 /**/ +/*#define HAS_LOCALTIME64 /**/ +/*#define HAS_GMTIME64 /**/ +/*#define HAS_MKTIME64 /**/ +/*#define HAS_DIFFTIME64 /**/ +/*#define HAS_ASCTIME64 /**/ + +/* HAS_TIMEGM: + * This symbol, if defined, indicates that the timegm routine is + * available to do the opposite of gmtime () + */ +/*#define HAS_TIMEGM /**/ + +/* U32_ALIGNMENT_REQUIRED: + * This symbol, if defined, indicates that you must access + * character data through U32-aligned pointers. + */ +#ifndef U32_ALIGNMENT_REQUIRED +#define U32_ALIGNMENT_REQUIRED /**/ +#endif + +/* HAS_UALARM: + * This symbol, if defined, indicates that the ualarm routine is + * available to do alarms with microsecond granularity. + */ +/*#define HAS_UALARM /**/ + +/* HAS_UNORDERED: + * This symbol, if defined, indicates that the unordered routine is + * available to check whether two doubles are unordered + * (effectively: whether either of them is NaN) + */ +/*#define HAS_UNORDERED /**/ + +/* HAS_UNSETENV: + * This symbol, if defined, indicates that the unsetenv () routine is + * available for use. + */ +/*#define HAS_UNSETENV /**/ + +/* HAS_USLEEP_PROTO: + * This symbol, if defined, indicates that the system provides + * a prototype for the usleep() function. Otherwise, it is up + * to the program to supply one. A good guess is + * extern int usleep(useconds_t); + */ +/*#define HAS_USLEEP_PROTO /**/ + +/* HAS_USTAT: + * This symbol, if defined, indicates that the ustat system call is + * available to query file system statistics by dev_t. + */ +/*#define HAS_USTAT /**/ + +/* HAS_WRITEV: + * This symbol, if defined, indicates that the writev routine is + * available to do scatter writes. + */ +/*#define HAS_WRITEV /**/ + +/* USE_DYNAMIC_LOADING: + * This symbol, if defined, indicates that dynamic loading of + * some sort is available. + */ +#define USE_DYNAMIC_LOADING /**/ + +/* FFLUSH_NULL: + * This symbol, if defined, tells that fflush(NULL) does flush + * all pending stdio output. + */ +/* FFLUSH_ALL: + * This symbol, if defined, tells that to flush + * all pending stdio output one must loop through all + * the stdio file handles stored in an array and fflush them. + * Note that if fflushNULL is defined, fflushall will not + * even be probed for and will be left undefined. + */ +#define FFLUSH_NULL /**/ +/*#define FFLUSH_ALL /**/ + +/* I_ASSERT: + * This symbol, if defined, indicates that <assert.h> exists and + * could be included by the C program to get the assert() macro. + */ +#define I_ASSERT /**/ + +/* I_CRYPT: + * This symbol, if defined, indicates that <crypt.h> exists and + * should be included. + */ +/*#define I_CRYPT /**/ + +/* DB_Prefix_t: + * This symbol contains the type of the prefix structure element + * in the <db.h> header file. In older versions of DB, it was + * int, while in newer ones it is u_int32_t. + */ +/* DB_Hash_t: + * This symbol contains the type of the prefix structure element + * in the <db.h> header file. In older versions of DB, it was + * int, while in newer ones it is size_t. + */ +/* DB_VERSION_MAJOR_CFG: + * This symbol, if defined, defines the major version number of + * Berkeley DB found in the <db.h> header when Perl was configured. + */ +/* DB_VERSION_MINOR_CFG: + * This symbol, if defined, defines the minor version number of + * Berkeley DB found in the <db.h> header when Perl was configured. + * For DB version 1 this is always 0. + */ +/* DB_VERSION_PATCH_CFG: + * This symbol, if defined, defines the patch version number of + * Berkeley DB found in the <db.h> header when Perl was configured. + * For DB version 1 this is always 0. + */ +#define DB_Hash_t int /**/ +#define DB_Prefix_t int /**/ +#define DB_VERSION_MAJOR_CFG 0 /**/ +#define DB_VERSION_MINOR_CFG 0 /**/ +#define DB_VERSION_PATCH_CFG 0 /**/ + +/* I_FP: + * This symbol, if defined, indicates that <fp.h> exists and + * should be included. + */ +/*#define I_FP /**/ + +/* I_FP_CLASS: + * This symbol, if defined, indicates that <fp_class.h> exists and + * should be included. + */ +/*#define I_FP_CLASS /**/ + +/* I_IEEEFP: + * This symbol, if defined, indicates that <ieeefp.h> exists and + * should be included. + */ +/*#define I_IEEEFP /**/ + +/* I_INTTYPES: + * This symbol, if defined, indicates to the C program that it should + * include <inttypes.h>. + */ +/*#define I_INTTYPES /**/ + +/* I_LANGINFO: + * This symbol, if defined, indicates that <langinfo.h> exists and + * should be included. + */ +/*#define I_LANGINFO /**/ + +/* I_LIBUTIL: + * This symbol, if defined, indicates that <libutil.h> exists and + * should be included. + */ +/*#define I_LIBUTIL /**/ + +/* I_MALLOCMALLOC: + * This symbol, if defined, indicates to the C program that it should + * include <malloc/malloc.h>. + */ +/*#define I_MALLOCMALLOC /**/ + +/* I_MNTENT: + * This symbol, if defined, indicates that <mntent.h> exists and + * should be included. + */ +/*#define I_MNTENT /**/ + +/* I_NETINET_TCP: + * This symbol, if defined, indicates to the C program that it should + * include <netinet/tcp.h>. + */ +/*#define I_NETINET_TCP /**/ + +/* I_POLL: + * This symbol, if defined, indicates that <poll.h> exists and + * should be included. (see also HAS_POLL) + */ +/*#define I_POLL /**/ + +/* I_PROT: + * This symbol, if defined, indicates that <prot.h> exists and + * should be included. + */ +/*#define I_PROT /**/ + +/* I_SHADOW: + * This symbol, if defined, indicates that <shadow.h> exists and + * should be included. + */ +/*#define I_SHADOW /**/ + +/* I_SOCKS: + * This symbol, if defined, indicates that <socks.h> exists and + * should be included. + */ +/*#define I_SOCKS /**/ + +/* I_SUNMATH: + * This symbol, if defined, indicates that <sunmath.h> exists and + * should be included. + */ +/*#define I_SUNMATH /**/ + +/* I_SYSLOG: + * This symbol, if defined, indicates that <syslog.h> exists and + * should be included. + */ +/*#define I_SYSLOG /**/ + +/* I_SYSMODE: + * This symbol, if defined, indicates that <sys/mode.h> exists and + * should be included. + */ +/*#define I_SYSMODE /**/ + +/* I_SYS_MOUNT: + * This symbol, if defined, indicates that <sys/mount.h> exists and + * should be included. + */ +/*#define I_SYS_MOUNT /**/ + +/* I_SYS_STATFS: + * This symbol, if defined, indicates that <sys/statfs.h> exists. + */ +/*#define I_SYS_STATFS /**/ + +/* I_SYS_STATVFS: + * This symbol, if defined, indicates that <sys/statvfs.h> exists and + * should be included. + */ +/*#define I_SYS_STATVFS /**/ + +/* I_SYSUTSNAME: + * This symbol, if defined, indicates that <sys/utsname.h> exists and + * should be included. + */ +/*#define I_SYSUTSNAME /**/ + +/* I_SYS_VFS: + * This symbol, if defined, indicates that <sys/vfs.h> exists and + * should be included. + */ +/*#define I_SYS_VFS /**/ + +/* I_USTAT: + * This symbol, if defined, indicates that <ustat.h> exists and + * should be included. + */ +/*#define I_USTAT /**/ + +/* PERL_PRIfldbl: + * This symbol, if defined, contains the string used by stdio to + * format long doubles (format 'f') for output. + */ +/* PERL_PRIgldbl: + * This symbol, if defined, contains the string used by stdio to + * format long doubles (format 'g') for output. + */ +/* PERL_PRIeldbl: + * This symbol, if defined, contains the string used by stdio to + * format long doubles (format 'e') for output. + */ +/* PERL_SCNfldbl: + * This symbol, if defined, contains the string used by stdio to + * format long doubles (format 'f') for input. + */ +/*#define PERL_PRIfldbl "f" /**/ +/*#define PERL_PRIgldbl "g" /**/ +/*#define PERL_PRIeldbl "e" /**/ +/*#define PERL_SCNfldbl "f" /**/ + +/* PERL_MAD: + * This symbol, if defined, indicates that the Misc Attribution + * Declaration code should be conditionally compiled. + */ +/*#define PERL_MAD /**/ + +/* NEED_VA_COPY: + * This symbol, if defined, indicates that the system stores + * the variable argument list datatype, va_list, in a format + * that cannot be copied by simple assignment, so that some + * other means must be used when copying is required. + * As such systems vary in their provision (or non-provision) + * of copying mechanisms, handy.h defines a platform- + * independent macro, Perl_va_copy(src, dst), to do the job. + */ +/*#define NEED_VA_COPY /**/ + +/* IVTYPE: + * This symbol defines the C type used for Perl's IV. + */ +/* UVTYPE: + * This symbol defines the C type used for Perl's UV. + */ +/* I8TYPE: + * This symbol defines the C type used for Perl's I8. + */ +/* U8TYPE: + * This symbol defines the C type used for Perl's U8. + */ +/* I16TYPE: + * This symbol defines the C type used for Perl's I16. + */ +/* U16TYPE: + * This symbol defines the C type used for Perl's U16. + */ +/* I32TYPE: + * This symbol defines the C type used for Perl's I32. + */ +/* U32TYPE: + * This symbol defines the C type used for Perl's U32. + */ +/* I64TYPE: + * This symbol defines the C type used for Perl's I64. + */ +/* U64TYPE: + * This symbol defines the C type used for Perl's U64. + */ +/* NVTYPE: + * This symbol defines the C type used for Perl's NV. + */ +/* IVSIZE: + * This symbol contains the sizeof(IV). + */ +/* UVSIZE: + * This symbol contains the sizeof(UV). + */ +/* I8SIZE: + * This symbol contains the sizeof(I8). + */ +/* U8SIZE: + * This symbol contains the sizeof(U8). + */ +/* I16SIZE: + * This symbol contains the sizeof(I16). + */ +/* U16SIZE: + * This symbol contains the sizeof(U16). + */ +/* I32SIZE: + * This symbol contains the sizeof(I32). + */ +/* U32SIZE: + * This symbol contains the sizeof(U32). + */ +/* I64SIZE: + * This symbol contains the sizeof(I64). + */ +/* U64SIZE: + * This symbol contains the sizeof(U64). + */ +/* NVSIZE: + * This symbol contains the sizeof(NV). + */ +/* NV_PRESERVES_UV: + * This symbol, if defined, indicates that a variable of type NVTYPE + * can preserve all the bits of a variable of type UVTYPE. + */ +/* NV_PRESERVES_UV_BITS: + * This symbol contains the number of bits a variable of type NVTYPE + * can preserve of a variable of type UVTYPE. + */ +/* NV_OVERFLOWS_INTEGERS_AT: + * This symbol gives the largest integer value that NVs can hold. This + * value + 1.0 cannot be stored accurately. It is expressed as constant + * floating point expression to reduce the chance of decimale/binary + * conversion issues. If it can not be determined, the value 0 is given. + */ +/* NV_ZERO_IS_ALLBITS_ZERO: + * This symbol, if defined, indicates that a variable of type NVTYPE + * stores 0.0 in memory as all bits zero. + */ +#ifdef _MSC_VER +# define IVTYPE __int64 /**/ +# define UVTYPE unsigned __int64 /**/ +#else +# define IVTYPE long long /**/ +# define UVTYPE unsigned long long /**/ +#endif +#define I8TYPE char /**/ +#define U8TYPE unsigned char /**/ +#define I16TYPE short /**/ +#define U16TYPE unsigned short /**/ +#define I32TYPE long /**/ +#define U32TYPE unsigned long /**/ +#ifdef HAS_QUAD +# ifdef _MSC_VER +# define I64TYPE __int64 /**/ +# define U64TYPE unsigned __int64 /**/ +# else +# define I64TYPE long long /**/ +# define U64TYPE unsigned long long /**/ +# endif +#endif +#define NVTYPE double /**/ +#define IVSIZE 8 /**/ +#define UVSIZE 8 /**/ +#define I8SIZE 1 /**/ +#define U8SIZE 1 /**/ +#define I16SIZE 2 /**/ +#define U16SIZE 2 /**/ +#define I32SIZE 4 /**/ +#define U32SIZE 4 /**/ +#ifdef HAS_QUAD +#define I64SIZE 8 /**/ +#define U64SIZE 8 /**/ +#endif +#define NVSIZE 8 /**/ +#undef NV_PRESERVES_UV +#define NV_PRESERVES_UV_BITS 53 +#define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0 +#define NV_ZERO_IS_ALLBITS_ZERO +#if UVSIZE == 8 +# ifdef BYTEORDER +# if BYTEORDER == 0x1234 +# undef BYTEORDER +# define BYTEORDER 0x12345678 +# else +# if BYTEORDER == 0x4321 +# undef BYTEORDER +# define BYTEORDER 0x87654321 +# endif +# endif +# endif +#endif + +/* IVdf: + * This symbol defines the format string used for printing a Perl IV + * as a signed decimal integer. + */ +/* UVuf: + * This symbol defines the format string used for printing a Perl UV + * as an unsigned decimal integer. + */ +/* UVof: + * This symbol defines the format string used for printing a Perl UV + * as an unsigned octal integer. + */ +/* UVxf: + * This symbol defines the format string used for printing a Perl UV + * as an unsigned hexadecimal integer in lowercase abcdef. + */ +/* UVXf: + * This symbol defines the format string used for printing a Perl UV + * as an unsigned hexadecimal integer in uppercase ABCDEF. + */ +/* NVef: + * This symbol defines the format string used for printing a Perl NV + * using %e-ish floating point format. + */ +/* NVff: + * This symbol defines the format string used for printing a Perl NV + * using %f-ish floating point format. + */ +/* NVgf: + * This symbol defines the format string used for printing a Perl NV + * using %g-ish floating point format. + */ +#define IVdf "I64d" /**/ +#define UVuf "I64u" /**/ +#define UVof "I64o" /**/ +#define UVxf "I64x" /**/ +#define UVXf "I64X" /**/ +#define NVef "e" /**/ +#define NVff "f" /**/ +#define NVgf "g" /**/ + +/* SELECT_MIN_BITS: + * This symbol holds the minimum number of bits operated by select. + * That is, if you do select(n, ...), how many bits at least will be + * cleared in the masks if some activity is detected. Usually this + * is either n or 32*ceil(n/32), especially many little-endians do + * the latter. This is only useful if you have select(), naturally. + */ +#define SELECT_MIN_BITS 32 /**/ + +/* STARTPERL: + * This variable contains the string to put in front of a perl + * script to make sure (one hopes) that it runs with perl and not + * some shell. + */ +#define STARTPERL "#!perl" /**/ + +/* HAS_STDIO_STREAM_ARRAY: + * This symbol, if defined, tells that there is an array + * holding the stdio streams. + */ +/* STDIO_STREAM_ARRAY: + * This symbol tells the name of the array holding the stdio streams. + * Usual values include _iob, __iob, and __sF. + */ +/*#define HAS_STDIO_STREAM_ARRAY /**/ +#ifdef HAS_STDIO_STREAM_ARRAY +#define STDIO_STREAM_ARRAY +#endif + +/* GMTIME_MAX: + * This symbol contains the maximum value for the time_t offset that + * the system function gmtime () accepts, and defaults to 0 + */ +/* GMTIME_MIN: + * This symbol contains the minimum value for the time_t offset that + * the system function gmtime () accepts, and defaults to 0 + */ +/* LOCALTIME_MAX: + * This symbol contains the maximum value for the time_t offset that + * the system function localtime () accepts, and defaults to 0 + */ +/* LOCALTIME_MIN: + * This symbol contains the minimum value for the time_t offset that + * the system function localtime () accepts, and defaults to 0 + */ +#define GMTIME_MAX 2147483647 /**/ +#define GMTIME_MIN 0 /**/ +#define LOCALTIME_MAX 2147483647 /**/ +#define LOCALTIME_MIN 0 /**/ + +/* USE_64_BIT_INT: + * This symbol, if defined, indicates that 64-bit integers should + * be used when available. If not defined, the native integers + * will be employed (be they 32 or 64 bits). The minimal possible + * 64-bitness is used, just enough to get 64-bit integers into Perl. + * This may mean using for example "long longs", while your memory + * may still be limited to 2 gigabytes. + */ +/* USE_64_BIT_ALL: + * This symbol, if defined, indicates that 64-bit integers should + * be used when available. If not defined, the native integers + * will be used (be they 32 or 64 bits). The maximal possible + * 64-bitness is employed: LP64 or ILP64, meaning that you will + * be able to use more than 2 gigabytes of memory. This mode is + * even more binary incompatible than USE_64_BIT_INT. You may not + * be able to run the resulting executable in a 32-bit CPU at all or + * you may need at least to reboot your OS to 64-bit mode. + */ +#ifndef USE_64_BIT_INT +#define USE_64_BIT_INT /**/ +#endif +#ifndef USE_64_BIT_ALL +/*#define USE_64_BIT_ALL /**/ +#endif + +/* USE_DTRACE: + * This symbol, if defined, indicates that Perl should + * be built with support for DTrace. + */ +/*#define USE_DTRACE /**/ + +/* USE_FAST_STDIO: + * This symbol, if defined, indicates that Perl should + * be built to use 'fast stdio'. + * Defaults to define in Perls 5.8 and earlier, to undef later. + */ +#ifndef USE_FAST_STDIO +/*#define USE_FAST_STDIO /**/ +#endif + +/* USE_LARGE_FILES: + * This symbol, if defined, indicates that large file support + * should be used when available. + */ +#ifndef USE_LARGE_FILES +#define USE_LARGE_FILES /**/ +#endif + +/* USE_LONG_DOUBLE: + * This symbol, if defined, indicates that long doubles should + * be used when available. + */ +#ifndef USE_LONG_DOUBLE +/*#define USE_LONG_DOUBLE /**/ +#endif + +/* USE_MORE_BITS: + * This symbol, if defined, indicates that 64-bit interfaces and + * long doubles should be used when available. + */ +#ifndef USE_MORE_BITS +/*#define USE_MORE_BITS /**/ +#endif + +/* MULTIPLICITY: + * This symbol, if defined, indicates that Perl should + * be built to use multiplicity. + */ +#ifndef MULTIPLICITY +#define MULTIPLICITY /**/ +#endif + +/* USE_PERLIO: + * This symbol, if defined, indicates that the PerlIO abstraction should + * be used throughout. If not defined, stdio should be + * used in a fully backward compatible manner. + */ +#ifndef USE_PERLIO +#define USE_PERLIO /**/ +#endif + +/* USE_SOCKS: + * This symbol, if defined, indicates that Perl should + * be built to use socks. + */ +#ifndef USE_SOCKS +/*#define USE_SOCKS /**/ +#endif + +#endif diff --git a/win32/makefile.mk b/win32/makefile.mk index 452cdc1b07..7eb5fc3eeb 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -34,7 +34,7 @@ INST_TOP *= $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -#INST_VER *= \5.11.1 +#INST_VER *= \5.11.2 # # Comment this out if you DON'T want your perl installation to have @@ -112,7 +112,7 @@ USE_LARGE_FILES *= define #CCTYPE *= MSVC90 # Borland 5.02 or later #CCTYPE *= BORLAND -# MinGW with gcc-2.95.2 or later +# MinGW or mingw-w64 with gcc-2.95.2 or later CCTYPE *= GCC # @@ -220,6 +220,29 @@ CCINCDIR *= $(CCHOME)\include CCLIBDIR *= $(CCHOME)\lib # +# If building with gcc-4.x.x (or x86_64-w64-mingw32-gcc-4.x.x), then +# uncomment the following assignment to GCC_4XX, make sure that CCHOME +# has been set correctly above, and uncomment the appropriate +# GCCHELPERDLL line. +# The name of the dll can change, depending upon which vendor has supplied +# your 4.x.x compiler, and upon the values of "x". +# (The dll will be in your mingw/bin folder, so check there if you're +# unsure about the correct name.) +# Without these corrections, the op/taint.t test script will fail. +# +#GCC_4XX *= define +#GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_sjlj-1.dll +#GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_dw2-1.dll +#GCCHELPERDLL *= $(CCHOME)\bin\libgcc_s_1.dll + +# +# uncomment this if you are using x86_64-w64-mingw32 cross-compiler +# ie if your gcc executable is called 'x86_64-w64-mingw32-gcc' +# instead of the usual 'gcc'. +# +#GCCCROSS *= define + +# # Additional compiler flags can be specified here. # BUILDOPT *= $(BUILDOPTEXTRA) @@ -444,7 +467,7 @@ LIBFILES = $(CRYPT_LIB) \ kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ - version.lib odbc32.lib odbccp32.lib \ + version.lib odbc32.lib odbccp32.lib comctl32.lib \ import32.lib $(LIBC) .IF "$(CFG)" == "Debug" @@ -475,11 +498,15 @@ LINK_FLAGS += -L"$(CCLIBDIR)\Release" .ELIF "$(CCTYPE)" == "GCC" -CC = gcc -LINK32 = g++ -LIB32 = ar rc -IMPLIB = dlltool -RSC = windres +.IF "$(GCCCROSS)" == "define" +ARCHPREFIX = x86_64-w64-mingw32- +.ENDIF + +CC = $(ARCHPREFIX)gcc +LINK32 = $(ARCHPREFIX)g++ +LIB32 = $(ARCHPREFIX)ar rc +IMPLIB = $(ARCHPREFIX)dlltool +RSC = $(ARCHPREFIX)windres i = .i o = .o @@ -491,6 +518,9 @@ a = .a INCLUDES = -I.\include -I. -I.. -I$(COREDIR) DEFINES = -DWIN32 $(CRYPT_FLAG) +.IF "$(WIN64)" == "define" +DEFINES += -DWIN64 -DCONSERVATIVE +.ENDIF LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -xc++ @@ -505,7 +535,7 @@ LIBFILES = $(CRYPT_LIB) $(LIBC) \ -lmoldname -lkernel32 -luser32 -lgdi32 \ -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 \ -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr \ - -lwinmm -lversion -lodbc32 -lodbccp32 + -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32 .IF "$(CFG)" == "Debug" OPTIMIZE = -g -O2 -DDEBUGGING @@ -603,14 +633,14 @@ LIBBASEFILES = $(CRYPT_LIB) \ oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ - version.lib odbc32.lib odbccp32.lib + version.lib odbc32.lib odbccp32.lib comctl32.lib # The 64 bit Platform SDK compilers contain a runtime library that doesn't # include the buffer overrun verification code used by the /GS switch. # Since the code links against libraries that are compiled with /GS, this # "security cookie verification" must be included via bufferoverlow.lib. .IF "$(WIN64)" == "define" -LIBBASEFILES = $(LIBBASEFILES) bufferoverflowU.lib +LIBBASEFILES += bufferoverflowU.lib .ENDIF # we add LIBC here, since we may be using PerlCRT.dll @@ -631,6 +661,14 @@ LIBOUT_FLAG = /out: CFLAGS_O = $(CFLAGS) $(BUILDOPT) +.IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC80FREE" || \ + "$(CCTYPE)" == "MSVC90" || "$(CCTYPE)" == "MSVC90FREE" +LINK_FLAGS += "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'" +.ELSE +RSC_FLAGS = -DINCLUDE_MANIFEST +.ENDIF + + # used to allow local linking flags that are not propogated into Config.pm, # currently unused # -- BKS, 12-12-1999 @@ -687,9 +725,9 @@ $(o).dll: .rc.res: .IF "$(CCTYPE)" == "GCC" - $(RSC) --use-temp-file --include-dir=. --include-dir=.. -O COFF -i $< -o $@ + $(RSC) --use-temp-file --include-dir=. --include-dir=.. -O COFF -D INCLUDE_MANIFEST -i $< -o $@ .ELSE - $(RSC) -i.. $< + $(RSC) -i.. -DINCLUDE_MANIFEST $< .ENDIF # @@ -711,15 +749,15 @@ PERLSTATIC = .ENDIF # Unicode data files generated by mktables -UNIDATAFILES = ..\lib\unicore\Canonical.pl ..\lib\unicore\Exact.pl \ - ..\lib\unicore\Properties ..\lib\unicore\Decomposition.pl \ +UNIDATAFILES = ..\lib\unicore\Decomposition.pl ..\lib\unicore\TestProp.pl \ ..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \ - ..\lib\unicore\PVA.pl + ..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst # Directories of Unicode data files generated by mktables UNIDATADIR1 = ..\lib\unicore\To UNIDATADIR2 = ..\lib\unicore\lib +PERLEXE_MANIFEST= .\perlexe.manifest PERLEXE_ICO = .\perlexe.ico PERLEXE_RES = .\perlexe.res PERLDLL_RES = @@ -783,8 +821,18 @@ CFGH_TMPL = config_H.bc .ELIF "$(CCTYPE)" == "GCC" +.IF "$(WIN64)" == "define" +.IF "$(GCCCROSS)" == "define" +CFGSH_TMPL = config.gc64 +CFGH_TMPL = config_H.gc64 +.ELSE +CFGSH_TMPL = config.gc64nox +CFGH_TMPL = config_H.gc64nox +.ENDIF +.ELSE CFGSH_TMPL = config.gc CFGH_TMPL = config_H.gc +.ENDIF PERLIMPLIB = ..\libperl511$(a) PERLSTATICLIB = ..\libperl511s$(a) @@ -1220,7 +1268,7 @@ $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) Extensions_static $(mktmp $(LKPRE) $(PERLDLL_OBJ) \ $(shell @type Extensions_static) \ $(LIBFILES) $(LKPOST)) - dlltool --output-lib $(PERLIMPLIB) \ + $(IMPLIB) --output-lib $(PERLIMPLIB) \ --dllname $(PERLDLL:b).dll \ --def perldll.def \ --base-file perl.base \ @@ -1258,7 +1306,7 @@ $(PERLSTATICLIB): Extensions_static .ENDIF $(XCOPY) $(PERLSTATICLIB) $(COREDIR) -$(PERLEXE_RES): perlexe.rc $(PERLEXE_ICO) +$(PERLEXE_RES): perlexe.rc $(PERLEXE_MANIFEST) $(PERLEXE_ICO) $(MINIMOD) : $(MINIPERL) ..\minimod.pl cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm @@ -1440,7 +1488,7 @@ utils: $(PERLEXE) $(X2P) copy ..\README.vmesa ..\pod\perlvmesa.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod - copy ..\pod\perl5112delta.pod ..\pod\perldelta.pod + copy ..\pod\perl5113delta.pod ..\pod\perldelta.pod cd ..\pod && $(MAKE) -f ..\win32\pod.mak converters $(PERLEXE) $(PL2BAT) $(UTILS) $(PERLEXE) $(ICWD) ..\autodoc.pl .. @@ -1514,8 +1562,8 @@ distclean: realclean perlmpeix.pod perlnetware.pod perlopenbsd.pod perlos2.pod \ perlos390.pod perlos400.pod perlplan9.pod perlqnx.pod \ perlriscos.pod perlsolaris.pod perlsymbian.pod perltoc.pod \ - perltru64.pod perltw.pod perluts.pod perlvmesa.pod perlvos.pod \ - perlwin32.pod \ + perltru64.pod perltw.pod perluniprops.pod perluts.pod \ + perlvmesa.pod perlvos.pod perlwin32.pod \ pod2html pod2latex pod2man pod2text pod2usage \ podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ @@ -1528,7 +1576,7 @@ distclean: realclean -del /f ..\lib\Config_git.pl -del /f bin\*.bat -del /f perllibst.h - -del /f perl.base + -del /f $(PERLEXE_RES) perl.base -cd .. && del /s *$(a) *.map *.pdb *.ilk *.tds *.bs *$(o) .exists pm_to_blib ppport.h -cd $(EXTDIR) && del /s *.def Makefile Makefile.old -cd $(DISTDIR) && del /s *.def Makefile Makefile.old @@ -1557,9 +1605,9 @@ installhtml : doc inst_lib : $(CONFIGPM) $(RCOPY) ..\lib $(INST_LIB)\*.* -$(UNIDATAFILES) .UPDATEALL : $(MINIPERL) $(CONFIGPM) ..\lib\unicore\mktables Extensions_nonxs +$(UNIDATAFILES) ..\pod\perluniprops.pod .UPDATEALL : $(MINIPERL) $(CONFIGPM) ..\lib\unicore\mktables Extensions_nonxs cd ..\lib\unicore && \ - ..\$(MINIPERL) -I.. -I..\..\cpan\Cwd\lib mktables + ..\$(MINIPERL) -I.. -I..\..\cpan\Cwd\lib -I..\..\cpan\Cwd mktables -P ..\..\pod -maketest -makelist -p minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) $(UNIDATAFILES) utils $(XCOPY) $(MINIPERL) ..\t\$(NULL) @@ -1582,6 +1630,11 @@ test-prep : all utils .ELSE $(XCOPY) $(GLOBEXE) ..\t\$(NULL) .ENDIF +.IF "$(CCTYPE)" == "GCC" +.IF "$(GCC_4XX)" == "define" + $(XCOPY) $(GCCHELPERDLL) ..\t\$(NULL) +.ENDIF +.ENDIF test : $(RIGHTMAKE) test-prep cd ..\t && $(PERLEXE) -I..\lib harness $(TEST_SWITCHES) $(TEST_FILES) diff --git a/win32/perlexe.manifest b/win32/perlexe.manifest new file mode 100755 index 0000000000..24ee19dca4 --- /dev/null +++ b/win32/perlexe.manifest @@ -0,0 +1,18 @@ +<?xml version="1.0" encoding="UTF-8" standalone="yes"?> +<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> + <assemblyIdentity version="0.0.0.0" name="Perl" type="Win32" /> + <description>Perl</description> + <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3"> + <security> + <requestedPrivileges> + <requestedExecutionLevel level="asInvoker" uiAccess="false" /> + </requestedPrivileges> + </security> + </trustInfo> + <dependency> + <dependentAssembly> + <assemblyIdentity type="Win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" + processorArchitecture="*" publicKeyToken="6595b64144ccf1df" language="*" /> + </dependentAssembly> + </dependency> +</assembly> diff --git a/win32/perlexe.rc b/win32/perlexe.rc index 627b8576b2..c22797826c 100644 --- a/win32/perlexe.rc +++ b/win32/perlexe.rc @@ -1 +1,8 @@ PERLEXE ICON perlexe.ico + +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#define RT_MANIFEST 24 + +#ifdef INCLUDE_MANIFEST +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "perlexe.manifest" +#endif diff --git a/win32/perlhost.h b/win32/perlhost.h index c2473c93f7..61f87659df 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -1747,7 +1747,7 @@ win32_start_child(LPVOID arg) parent_message_hwnd = w32_message_hwnd; w32_message_hwnd = win32_create_message_window(); if (parent_message_hwnd != NULL) - PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LONG)w32_message_hwnd); + PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LPARAM)w32_message_hwnd); /* push a zero on the stack (we are the child) */ { @@ -1762,7 +1762,7 @@ win32_start_child(LPVOID arg) { dJMPENV; - volatile int oldscope = PL_scopestack_ix; + volatile int oldscope = 1; /* We are responsible for all scopes */ restart: JMPENV_PUSH(status); diff --git a/win32/pod.mak b/win32/pod.mak index e18b71c1c4..6b52c523ca 100644 --- a/win32/pod.mak +++ b/win32/pod.mak @@ -25,6 +25,7 @@ POD = \ perl5110delta.pod \ perl5111delta.pod \ perl5112delta.pod \ + perl5113delta.pod \ perl561delta.pod \ perl56delta.pod \ perl570delta.pod \ @@ -138,6 +139,7 @@ POD = \ perlunicode.pod \ perlunifaq.pod \ perluniintro.pod \ + perluniprops.pod \ perlunitut.pod \ perlutil.pod \ perlvar.pod \ @@ -154,6 +156,7 @@ MAN = \ perl5110delta.man \ perl5111delta.man \ perl5112delta.man \ + perl5113delta.man \ perl561delta.man \ perl56delta.man \ perl570delta.man \ @@ -267,6 +270,7 @@ MAN = \ perlunicode.man \ perlunifaq.man \ perluniintro.man \ + perluniprops.man \ perlunitut.man \ perlutil.man \ perlvar.man \ @@ -283,6 +287,7 @@ HTML = \ perl5110delta.html \ perl5111delta.html \ perl5112delta.html \ + perl5113delta.html \ perl561delta.html \ perl56delta.html \ perl570delta.html \ @@ -395,6 +400,7 @@ HTML = \ perlunicode.html \ perlunifaq.html \ perluniintro.html \ + perluniprops.html \ perlunitut.html \ perlutil.html \ perlvar.html \ @@ -412,6 +418,7 @@ TEX = \ perl5110delta.tex \ perl5111delta.tex \ perl5112delta.tex \ + perl5113delta.tex \ perl561delta.tex \ perl56delta.tex \ perl570delta.tex \ @@ -525,6 +532,7 @@ TEX = \ perlunicode.tex \ perlunifaq.tex \ perluniintro.tex \ + perluniprops.tex \ perlunitut.tex \ perlutil.tex \ perlvar.tex \ diff --git a/win32/win32.c b/win32/win32.c index 41fae60b66..b9eea70535 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -22,6 +22,7 @@ # define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */ #endif #include <winnt.h> +#include <commctrl.h> #include <tlhelp32.h> #include <io.h> #include <signal.h> @@ -64,7 +65,6 @@ typedef struct { #define PERL_NO_GET_CONTEXT #include "XSUB.h" -#include "Win32iop.h" #include <fcntl.h> #ifndef __GNUC__ /* assert.h conflicts with #define of assert in perl.h */ @@ -2014,7 +2014,7 @@ win32_uname(struct utsname *name) GetSystemInfo(&info); #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \ - || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION)) + || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION)) procarch = info.u.s.wProcessorArchitecture; #else procarch = info.wProcessorArchitecture; @@ -2505,7 +2505,6 @@ my_open_osfhandle(intptr_t osfhandle, int flags) /* simulate flock by locking a range on the file */ -#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError())) #define LK_LEN 0xffff0000 DllExport int @@ -2521,34 +2520,46 @@ win32_flock(int fd, int oper) return -1; } fh = (HANDLE)_get_osfhandle(fd); + if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */ + return -1; + memset(&o, 0, sizeof(o)); switch(oper) { case LOCK_SH: /* shared lock */ - LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i); + if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o)) + i = 0; break; case LOCK_EX: /* exclusive lock */ - LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i); + if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o)) + i = 0; break; case LOCK_SH|LOCK_NB: /* non-blocking shared lock */ - LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i); + if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o)) + i = 0; break; case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */ - LK_ERR(LockFileEx(fh, - LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY, - 0, LK_LEN, 0, &o),i); + if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY, + 0, LK_LEN, 0, &o)) + i = 0; break; case LOCK_UN: /* unlock lock */ - LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i); + if (UnlockFileEx(fh, 0, LK_LEN, 0, &o)) + i = 0; break; default: /* unknown */ errno = EINVAL; - break; + return -1; + } + if (i == -1) { + if (GetLastError() == ERROR_LOCK_VIOLATION) + errno = WSAEWOULDBLOCK; + else + errno = EINVAL; } return i; } -#undef LK_ERR #undef LK_LEN /* @@ -2612,21 +2623,24 @@ win32_strerror(int e) #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */ extern int sys_nerr; #endif - DWORD source = 0; if (e < 0 || e > sys_nerr) { dTHX; if (e < 0) e = GetLastError(); - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0, - w32_strerror_buffer, - sizeof(w32_strerror_buffer), NULL) == 0) + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0, + w32_strerror_buffer, sizeof(w32_strerror_buffer), + NULL) == 0) + { strcpy(w32_strerror_buffer, "Unknown Error"); - + } return w32_strerror_buffer; } +#undef strerror return strerror(e); +#define strerror win32_strerror } DllExport void @@ -4804,6 +4818,16 @@ Perl_win32_init(int *argcp, char ***argvp) #endif MALLOC_INIT; + /* When the manifest resource requests Common-Controls v6 then + * user32.dll no longer registers all the Windows classes used for + * standard controls but leaves some of them to be registered by + * comctl32.dll. InitCommonControls() doesn't do anything but calling + * it makes sure comctl32.dll gets loaded into the process and registers + * the standard control classes. Without this even normal Windows APIs + * like MessageBox() can fail under some versions of Windows XP. + */ + InitCommonControls(); + module = GetModuleHandle("ntdll.dll"); if (module) { *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation"); diff --git a/win32/win32.h b/win32/win32.h index c14367a4c5..3916b2e1f6 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -58,6 +58,23 @@ #define WIN32_LEAN_AND_MEAN #include <windows.h> +/* + * Bug in winbase.h in mingw-w64 4.4.0-1 at least... they + * do #define GetEnvironmentStringsA GetEnvironmentStrings and fail + * to declare GetEnvironmentStringsA. + */ +#if defined(__MINGW64__) && defined(GetEnvironmentStringsA) && !defined(UNICODE) +#ifdef __cplusplus +extern "C" { +#endif +#undef GetEnvironmentStringsA +WINBASEAPI LPCH WINAPI GetEnvironmentStringsA(VOID); +#define GetEnvironmentStrings GetEnvironmentStringsA +#ifdef __cplusplus +} +#endif +#endif + #ifdef WIN32_LEAN_AND_MEAN /* C file is NOT a Perl5 original. */ #define CONTEXT PERL_CONTEXT /* Avoid conflict of CONTEXT defs. */ #endif /*WIN32_LEAN_AND_MEAN */ diff --git a/win32/win32iop.h b/win32/win32iop.h index b03e9a753c..7507408f00 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -161,7 +161,9 @@ DllExport Sighandler_t win32_signal(int sig, Sighandler_t subcode); END_EXTERN_C #undef alarm -#define alarm win32_alarm +#define alarm win32_alarm +#undef strerror +#define strerror win32_strerror /* * the following six(6) is #define in stdio.h @@ -205,7 +207,6 @@ END_EXTERN_C #define ferror(f) win32_ferror(f) #define errno (*win32_errno()) #define environ (*win32_environ()) -#define strerror win32_strerror /* * redirect to our own version @@ -294,6 +295,10 @@ END_EXTERN_C #define free win32_free #endif +/* XXX Why are APIs like sleep(), times() etc. inside a block + * XXX guarded by "#ifndef WIN32IO_IS_STDIO"? + */ + #define pipe(fd) win32_pipe((fd), 512, O_BINARY) #define pause() win32_sleep((32767L << 16) + 32767) #define sleep win32_sleep |